src/c/mswin/config.lsp

   1 (defpackage setup (:use xlisp))
   2
   3 (in-package setup)
   4
   5 (defvar *progman-available*
   6         (let ((conv (dde-connect "progman")))
   7           (if conv (dde-disconnect conv))
   8           conv))
   9
  10 (defproto preference-item-proto
  11   '(section name default) () edit-text-item-proto)
  12
  13 (defmeth preference-item-proto :isnew (section name default &rest args)
  14   (setf (slot-value 'section) section)
  15   (setf (slot-value 'name) name)
  16   (setf (slot-value 'default) default)
  17   (apply #'call-next-method default args))
  18
  19 (defmeth preference-item-proto :configure ()
  20   (msw-write-profile-string (slot-value 'section)
  21                             (slot-value 'name)
  22                             (send self :text)
  23                             #+win32 "wxls32.ini"
  24                             #-win32 "wxls.ini"))
  25
  26 (defproto directory-item-proto () () preference-item-proto)
  27
  28 (defmeth directory-item-proto :isnew ()
  29   (call-next-method "Xlisp"
  30                     "Libdir"
  31                     (get-working-directory)
  32                     :text-length 25))
  33
  34
  35 (defproto font-name-item-proto () () preference-item-proto)
  36
  37 (defmeth font-name-item-proto :isnew (section &optional
  38                                               (font "Courier New")
  39                                               (size 16))
  40   (call-next-method section "Font" font :text-length size))
  41
  42 (defproto font-size-item-proto () () preference-item-proto)
  43
  44 (defmeth font-size-item-proto :isnew (section &optional (size 12))
  45   (call-next-method section "FontSize" (format nil "~d" size)))
  46
  47 (defmeth font-size-item-proto :configure ()
  48   (let ((n (read-from-string (send self :text) nil)))
  49     (unless (integerp n)
  50             (send self :text (slot-value 'default)))
  51     (call-next-method)))
  52
  53 (defproto progman-item-proto () () edit-text-item-proto)
  54
  55 (defmeth progman-item-proto :exec (&rest args)
  56   (let ((conv (dde-connect "progman")))
  57    (when conv
  58          (unwind-protect
  59           (dde-client-transaction conv :data (apply #'format nil args))
  60           (dde-disconnect conv)))))
  61
  62 (defproto progman-group-item-proto () () progman-item-proto)
  63
  64 (defun progman-group-exists (group)
  65   (let ((conv (dde-connect "progman")))
  66    (when conv
  67          (unwind-protect
  68           (dde-client-transaction conv :type :request :item group)
  69           (dde-disconnect conv)))))
  70
  71
  72 (defmeth progman-group-item-proto :configure ()
  73   (let ((group (send self :text)))
  74     (when (progman-group-exists group)
  75           (let ((delete (ok-or-cancel-dialog
  76                          (format nil "Delete existing ~a group?"
  77                                  group))))
  78             (if delete
  79                 (send self :exec "[DeleteGroup(~a)]" group)
  80                 (throw 'cancel nil)))))
  81   (send self :exec "[CreateGroup(~a)]" (send self :text)))
  82
  83 (defproto progman-program-item-proto
  84  '(application directory icon x y) () progman-item-proto)
  85
  86 (defmeth progman-program-item-proto :isnew (n a d i x y)
  87   (setf (slot-value 'application) a)
  88   (setf (slot-value 'directory) d)
  89   (setf (slot-value 'icon) i)
  90   (setf (slot-value 'x) x)
  91   (setf (slot-value 'y) y)
  92   (call-next-method n))
  93
  94 (defmeth progman-program-item-proto :configure ()
  95   (let* ((dir (send (slot-value 'directory) :text))
  96          (app (slot-value 'application))
  97          (file (format nil "~a\\~a" dir app)))
  98     (send self :exec "[AddItem(~a,~a,~a,~d,~d,~d,~a)]"
  99           file
 100           (send self :text)
 101           file
 102           (slot-value 'icon)
 103           (slot-value 'x)
 104           (slot-value 'y)
 105           (send (slot-value 'directory) :text))))
 106
 107 (let* ((list-font-size 12)
 108        (graph-font-size 12)
 109        (dir-item (send directory-item-proto :new))
 110        (list-font-item (send font-name-item-proto :new "Listener"))
 111        (list-font-size-item (send font-size-item-proto :new "Listener"))
 112        (graph-font-item (send font-name-item-proto :new "Graphics"))
 113        (graph-font-size-item (send font-size-item-proto :new "Graphics"))
 114        (progman-item (send toggle-item-proto :new
 115                            "Add Group and Items to Program Manager"
 116                            :value t))
 117        (group-name-item (send progman-group-item-proto :new
 118                               (format nil "XLISP-STAT ~d.~d~a"
 119                                       xls-major-release
 120                                       xls-minor-release
 121                                       #+win32 " - Win32"
 122                                       #-win32 "")))
 123        (xls-name-item (send progman-program-item-proto :new
 124                             "XLISP-STAT"
 125                             #+win32 "WXLS32.EXE"
 126                             #-win32 "WXLS.EXE"
 127                             dir-item 2 30 20))
 128        (lspedit-name-item (send progman-program-item-proto :new
 129                                 "Lsp Edit" "LSPEDIT.EXE"
 130                                 dir-item 0 90 20)))
 131   (flet ((configure ()
 132            (catch 'cancel
 133                   (send dir-item :configure)
 134                   (send list-font-item :configure)
 135                   (send list-font-size-item :configure)
 136                   (send graph-font-item :configure)
 137                   (send graph-font-size-item :configure)
 138                   (when (and *progman-available*
 139                              (send progman-item :value))
 140                         (send group-name-item :configure)
 141                         (send xls-name-item :configure)
 142                         (send lspedit-name-item :configure)))
 143            (msw-exit))
 144          (quit () (msw-exit)))
 145     (let ((pref-items (list (list "Startup Directory:" dir-item)
 146                             (list
 147                              (list
 148                               (list "Listener Font:" list-font-item)
 149                               (list "Graphics Font:" graph-font-item))
 150                              (list
 151                               (list "Size:" list-font-size-item)
 152                               (list "Size:" graph-font-size-item)))))
 153           (pm-items (list progman-item
 154                           (list "Program Group Name:" group-name-item)
 155                           (list (format nil "Program Item Name for ~a:"
 156                                         #+win32 "WXLS32.EXE"
 157                                         #-win32 "WXLS.EXE")
 158                                 xls-name-item)
 159                           (list "Program Item Name for LSPEDIT.EXE:"
 160                                 lspedit-name-item)))
 161           (buttons (list (list (send button-item-proto :new
 162                                      "Configure and Quit"
 163                                      :action #'configure)
 164                                (send button-item-proto :new
 165                                      "Quit"
 166                                      :action #'quit)))))
 167     (send dialog-proto :new
 168           (append pref-items
 169                   (if *progman-available* pm-items)
 170                   buttons)
 171           :title "XLISP-STAT Setup"
 172           :location '(0 0)))))
 173
 174 (unless (probe-file "Data\\absorbtion.lsp")
 175         ;; looks like a system that supports long file names -- rename
 176         ;; some files in Data and Examples.
 177         (rename-file "Data\\absorbti.lsp" "Data\\absorbtion.lsp")
 178         (rename-file "Data\\car-pric.lsp" "Data\\car-prices.lsp")
 179         (rename-file "Data\\metaboli.lsp" "Data\\metabolism.lsp")
 180         (rename-file "Data\\puromyci.lsp" "Data\\puromycin.lsp")
 181         (rename-file "Data\\stacklos.lsp" "Data\\stackloss.lsp")
 182         (rename-file "Examples\\abrasion.lsp" "Examples\\abrasiondemo.lsp")
 183         (rename-file "Examples\\addhandr.lsp" "Examples\\addhandrotate.lsp")
 184         (rename-file "Examples\\dataprot.lsp" "Examples\\dataprotos.lsp")
 185         (rename-file "Examples\\plotcont.lsp" "Examples\\plotcontrols.lsp")
 186         (rename-file "Examples\\rotatede.lsp" "Examples\\rotatedemo.lsp")
 187         (when (probe-file "xlsclien.exe")
 188           (rename-file "xlsclien.exe" "xlsclient.exe")))