; 07 Jan 2010 16:43:40 EST
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.

; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.

; You should have received a copy of the GNU General Public License
; along with this program; if not, see <http://www.gnu.org/licenses/>.


(DEFUN EDIT-THERMOM (NUM W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
  (PROG (NMIN NDEL NDIV RANGE PTEN DRANGE PAIR NEWW (RES NUM) OFF)
    (WHEN (NOT SIZEX) (SETQ SIZEX 150) (SETQ SIZEY 250))
    (WHEN (NOT OFFSETX)
      (SETQ OFF
            (LET ((GLVAR168 (LIST SIZEX SIZEY)))
              (LIST (TRUNCATE (- (FIFTH W) (CAR GLVAR168)) 2)
                    (TRUNCATE (- (CADDDR W) (CADR GLVAR168)) 2))))
      (SETQ OFFSETX (CAR OFF))
      (SETQ OFFSETY (CADR OFF)))
    (SETQ NEWW
          (WINDOW-CREATE SIZEX SIZEY NIL (CADR W) OFFSETX OFFSETY))
    (WINDOW-DRAW-BUTTON NEWW "Typein" 80 20 50 25)
    (WINDOW-DRAW-BUTTON NEWW "Adjust" 80 70 50 25)
    (WINDOW-DRAW-BUTTON NEWW "Done" 80 120 50 25)
    RN
    (SETQ RANGE (* 2 (ABS RES)))
    (IF (ZEROP RANGE) (SETQ RANGE 50))
    (IF (AND (< RANGE 8) (INTEGERP NUM)) (SETQ RANGE 10))
    (SETQ PTEN (EXPT 10 (TRUNCATE (LOG RANGE 10))))
    (SETQ DRANGE (/ (* 10 RANGE) PTEN))
    (SETQ PAIR
          (CAR (SOME #'(LAMBDA (X) (> (CAR X) DRANGE))
                     '((14 2) (20 4) (40 5) (70 10) (101 20)))))
    (SETQ NDEL (* 1/10 (* (CADR PAIR) PTEN)))
    (SETQ NDIV (CEILING (/ RANGE NDEL)))
    (SETQ NMIN (IF (>= RES 0) 0 (- (* NDEL NDIV))))
    (WINDOW-DRAW-THERMOMETER NEWW NMIN NDEL NDIV RES 10 10
        (+ -20 SIZEY))
    LP
    (CASE (BUTTON-SELECT NEWW
              '((DONE (84 124) (42 17)) (ADJUST (84 74) (42 17))
                (TYPEIN (84 24) (42 17))))
      (DONE (XDESTROYWINDOW *WINDOW-DISPLAY* (CADR NEWW))
            (XFLUSH *WINDOW-DISPLAY*) (SETF (CADR NEWW) NIL)
            (XFREEGC *WINDOW-DISPLAY* (CADDR NEWW))
            (SETF (CADDR NEWW) NIL) (RETURN RES))
      (ADJUST (SETQ RES
                    (WINDOW-ADJUST-THERMOMETER NEWW NMIN NDEL NDIV RES
                        10 10 (+ -20 SIZEY)))
              (GO LP))
      (TYPEIN (PRINC "Enter new value: ") (SETQ RES (READ))
              (IF (AND (>= RES NMIN) (<= RES (+ NMIN (* NDEL NDIV))))
                  (PROGN
                    (WINDOW-SET-THERMOMETER NEWW NMIN NDEL NDIV RES 10
                        10 (+ -20 SIZEY))
                    (GO LP))
                  (GO RN))))))
(SETF (GET 'EDIT-THERMOM 'GLARGUMENTS)
      '((NUM NUMBER) (W WINDOW) (&OPTIONAL INTEGER) (OFFSETX INTEGER)
        (OFFSETY INTEGER) (SIZEX INTEGER)))
(SETF (GET 'EDIT-THERMOM 'GLFNRESULTTYPE) 'NUMBER)


(DEFUN WINDOW-DRAW-BUTTON (W S OFFSETX OFFSETY SIZEX SIZEY)
  (LET (SW)
    (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX
        (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0)
    (WINDOW-DRAW-RCBOX-XY W OFFSETX OFFSETY SIZEX SIZEY 8)
    (SETQ SW
          (LET ((SSTR (STRINGIFY S)))
            (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))))
    (LET ((SSTR (STRINGIFY S)))
      (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W)
          (+ OFFSETX (* 1/2 (- SIZEX SW)))
          (+ -8 (- (CADDDR W) OFFSETY)) (GET-C-STRING SSTR)
          (LENGTH SSTR)))
    (XFLUSH *WINDOW-DISPLAY*)))

(DEFUN WINDOW-CENTER-PRINT (W S OFFSETX OFFSETY SIZEX SIZEY)
  (LET (SW)
    (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX
        (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0)
    (SETQ SW
          (LET ((SSTR (STRINGIFY S)))
            (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))))
    (LET ((SSTR (STRINGIFY S)))
      (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W)
          (+ OFFSETX (* 1/2 (- SIZEX SW)))
          (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY))))
          (GET-C-STRING SSTR) (LENGTH SSTR)))
    (XFLUSH *WINDOW-DISPLAY*)))

(DEFUN WINDOW-DRAW-THERMOMETER
       (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY)
  (LET (HDEL MARKY)
    (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX
        (- (CADDDR W) (1- (+ OFFSETY SIZEY))) 66 SIZEY 0)
    (EDITORS-PRINT-IN-BOX VAL W OFFSETX OFFSETY 40 20)
    (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) OFFSETX
        (+ -48 (- (CADDDR W) OFFSETY)) 24 24 8448 17664)
    (LET ((QQWHEIGHT (CADDDR W)))
      (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX)
          (+ -44 (- QQWHEIGHT OFFSETY)) (+ 4 OFFSETX)
          (+ 8 (- QQWHEIGHT (+ OFFSETY SIZEY)))))
    (LET ((QQWHEIGHT (CADDDR W)))
      (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 20 OFFSETX)
          (+ -44 (- QQWHEIGHT OFFSETY)) (+ 20 OFFSETX)
          (+ 8 (- QQWHEIGHT (+ OFFSETY SIZEY)))))
    (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX)
        (- (CADDDR W) (+ OFFSETY SIZEY)) 16 16 0 11520)
    (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0)
    (XDRAWARC *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 8 OFFSETX)
        (+ -40 (- (CADDDR W) OFFSETY)) 8 8 0 23040)
    (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0)
    (SETQ HDEL (/ (+ -56 SIZEY) NDIV))
    (LET ((QQWHEIGHT (CADDDR W)))
      (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0)
      (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 12 OFFSETX)
          (+ -35 (- QQWHEIGHT OFFSETY)) (+ 12 OFFSETX)
          (- QQWHEIGHT
             (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL)))))
      (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))
    (DOTIMES (I (1+ NDIV))
      (SETQ MARKY (+ (+ 48 OFFSETY) (* I HDEL)))
      (LET ((QQWHEIGHT (CADDDR W)))
        (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 24 OFFSETX)
            (- QQWHEIGHT MARKY) (+ 34 OFFSETX) (- QQWHEIGHT MARKY))
        NIL)
      (LET ((SSTR (STRINGIFY (+ NMIN (* I NDEL)))))
        (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W)
            (+ 36 OFFSETX) (+ 6 (- (CADDDR W) MARKY))
            (GET-C-STRING SSTR) (LENGTH SSTR))))
    (XFLUSH *WINDOW-DISPLAY*)))

(DEFUN WINDOW-SET-THERMOMETER
       (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY)
  (LET (HDEL)
    (SETQ HDEL (/ (+ -56 SIZEY) NDIV))
    (LET ((GLVAR204 (+ -56 SIZEY)))
      (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 7 OFFSETX)
          (- (CADDDR W) (1- (+ (+ 48 OFFSETY) GLVAR204))) 10 GLVAR204
          0))
    (LET ((QQWHEIGHT (CADDDR W)))
      (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0 1 0)
      (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 12 OFFSETX)
          (+ -35 (- QQWHEIGHT OFFSETY)) (+ 12 OFFSETX)
          (- QQWHEIGHT
             (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL)))))
      (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0 1 0))
    (EDITORS-UPDATE-IN-BOX VAL W OFFSETX OFFSETY 40 20)))

(DEFUN WINDOW-ADJUST-THERMOMETER
       (W NMIN NDEL NDIV VAL OFFSETX OFFSETY SIZEY)
  (LET (HDEL LASTY XMIN XMAX YMIN YMAX INSIDE NEWVAL)
    (SETQ HDEL (/ (+ -56 SIZEY) NDIV))
    (SETQ LASTY
          (TRUNCATE (+ (+ 48 OFFSETY) (* HDEL (/ (- VAL NMIN) NDEL)))))
    (SETQ XMIN (+ 4 OFFSETX))
    (SETQ XMAX (+ 20 OFFSETX))
    (SETQ YMIN (+ 48 OFFSETY))
    (SETQ YMAX (+ -8 (+ OFFSETY SIZEY)))
    (WINDOW-TRACK-MOUSE W
        #'(LAMBDA (X Y CODE)
            (SETQ INSIDE
                  (AND (>= X XMIN) (<= X XMAX) (>= Y YMIN) (<= Y YMAX)))
            (WHEN (AND INSIDE (/= Y LASTY))
              (IF (> Y LASTY)
                  (LET ((QQWHEIGHT (CADDDR W)))
                    (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 7 0
                        1 0)
                    (XDRAWLINE *WINDOW-DISPLAY* (CADR W) (CADDR W)
                        (+ 12 OFFSETX) (- QQWHEIGHT LASTY)
                        (+ 12 OFFSETX) (- QQWHEIGHT Y))
                    (XSETLINEATTRIBUTES *WINDOW-DISPLAY* (CADDR W) 1 0
                        1 0))
                  (LET ((GLVAR214 (- LASTY Y)))
                    (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 7 OFFSETX)
                        (- (CADDDR W) (1- (+ (1+ Y) GLVAR214))) 10
                        GLVAR214 0)))
              (SETQ LASTY Y)
              (SETQ NEWVAL
                    (+ (* (/ (+ -48 (- LASTY OFFSETY)) (FLOAT HDEL))
                          NDEL)
                       NMIN))
              (IF (INTEGERP VAL) (SETQ NEWVAL (TRUNCATE NEWVAL)))
              (EDITORS-UPDATE-IN-BOX NEWVAL W OFFSETX OFFSETY 40 20))
            (NOT (ZEROP CODE))))
    (IF INSIDE NEWVAL VAL)))
(SETF (GET 'WINDOW-ADJUST-THERMOMETER 'GLARGUMENTS)
      '((W WINDOW) (NMIN INTEGER) (NDEL INTEGER) (NDIV INTEGER)
        (VAL NUMBER) (OFFSETX INTEGER) (OFFSETY INTEGER)
        (SIZEY INTEGER)))
(SETF (GET 'WINDOW-ADJUST-THERMOMETER 'GLFNRESULTTYPE) 'NUMBER)


(DEFUN BUTTON-SELECT (MW BUTTONS)
  (LET (CURRENT-BUTTON ITEM ITEMS VAL XZERO YZERO)
    (SETQ XZERO 0)
    (SETQ YZERO 0)
    (WINDOW-TRACK-MOUSE MW
        #'(LAMBDA (X Y CODE)
            (DECF X XZERO)
            (DECF Y YZERO)
            (AND (>= X 0) (>= Y 0))
            (IF CURRENT-BUTTON
                (WHEN (NOT (BUTTON-CONTAINSXY? CURRENT-BUTTON X Y))
                  (BUTTON-INVERT MW CURRENT-BUTTON)
                  (SETQ CURRENT-BUTTON NIL)))
            (WHEN (NOT CURRENT-BUTTON)
              (SETQ ITEMS BUTTONS)
              (WHILE (AND (NOT CURRENT-BUTTON) (SETQ ITEM (POP ITEMS)))
                     (WHEN (BUTTON-CONTAINSXY? ITEM X Y)
                       (SETQ CURRENT-BUTTON ITEM)
                       (BUTTON-INVERT MW CURRENT-BUTTON))))
            (WHEN (PLUSP CODE)
              (IF CURRENT-BUTTON (BUTTON-INVERT MW CURRENT-BUTTON))
              (SETQ VAL (OR CURRENT-BUTTON *PICMENU-NO-SELECTION*))))
        T)
    (IF (NOT (EQUAL VAL *PICMENU-NO-SELECTION*)) (CAR VAL))))
(SETF (GET 'BUTTON-SELECT 'GLARGUMENTS)
      '((MW WINDOW) (BUTTONS (LISTOF PICMENU-BUTTON))))
(SETF (GET 'BUTTON-SELECT 'GLFNRESULTTYPE) 'SYMBOL)


(DEFUN BUTTON-INVERT (W BUTTON)
  (WINDOW-INVERT-AREA W (CADR BUTTON) (CADDR BUTTON)))

(DEFUN WINDOW-UNDRAW-BOX (W OFFSET SIZE &OPTIONAL LW)
  (LET ((GC (CADDR W)))
    (SETQ *WINDOW-SAVE-FUNCTION*
          (PROGN
            (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1 *GC-VALUES*)
            (XGCVALUES-FUNCTION *GC-VALUES*)))
    (XSETFUNCTION *WINDOW-DISPLAY* GC 3)
    (SETQ *WINDOW-SAVE-FOREGROUND*
          (PROGN
            (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4 *GC-VALUES*)
            (XGCVALUES-FOREGROUND *GC-VALUES*)))
    (XSETFOREGROUND *WINDOW-DISPLAY* GC
        (PROGN
          (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8 *GC-VALUES*)
          (XGCVALUES-BACKGROUND *GC-VALUES*))))
  (WINDOW-DRAW-BOX W OFFSET SIZE LW)
  (LET ((GC (CADDR W)))
    (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*)
    (XSETFOREGROUND *WINDOW-DISPLAY* GC *WINDOW-SAVE-FOREGROUND*)))

(DEFUN BUTTON-CONTAINSXY? (B X Y)
  (LET ((XSIZE 6) (YSIZE 6))
    (WHEN (CADDR B)
      (SETQ XSIZE (CAADDR B))
      (SETQ YSIZE (CADR (CADDR B))))
    (AND (>= X (CAADR B)) (<= X (+ (CAADR B) XSIZE)) (>= Y (CADADR B))
         (<= Y (+ (CADADR B) YSIZE)))))
(SETF (GET 'BUTTON-CONTAINSXY? 'GLARGUMENTS)
      '((B PICMENU-BUTTON) (X INTEGER) (Y INTEGER)))
(SETF (GET 'BUTTON-CONTAINSXY? 'GLFNRESULTTYPE) 'BOOLEAN)


(SETF (GET 'MENU-ITEM 'GLSTRUCTURE)
      '((Z ANYTHING) PROP ((VALUE ((IF Z IS ATOMIC Z (CDR Z))))) MSG
        ((PRINT-SIZE MENU-ITEM-PRINT-SIZE) (DRAW MENU-ITEM-DRAW))))


(DEFUN MENU-ITEM-PRINT-SIZE (ITEM W)
  (LET (SIZ)
    (IF (ATOM ITEM)
        (LIST (LET ((SSTR (STRINGIFY ITEM)))
                (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR)
                    (LENGTH SSTR)))
              11)
        (IF (STRINGP (CAR ITEM))
            (LIST (LET ((SSTR (STRINGIFY (CAR ITEM))))
                    (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR)
                        (LENGTH SSTR)))
                  11)
            (IF (AND (SYMBOLP (CAR ITEM))
                     (SETQ SIZ (GET (CAR ITEM) 'DISPLAY-SIZE)))
                SIZ (COPY-LIST '(50 11)))))))
(SETF (GET 'MENU-ITEM-PRINT-SIZE 'GLARGUMENTS)
      '((ITEM MENU-ITEM) (W WINDOW)))
(SETF (GET 'MENU-ITEM-PRINT-SIZE 'GLFNRESULTTYPE) 'VECTOR)


(DEFUN MENU-ITEM-DRAW (ITEM W OFFSETX OFFSETY SIZEX SIZEY)
  (IF (ATOM ITEM)
      (WINDOW-CENTER-PRINT W ITEM OFFSETX OFFSETY SIZEX SIZEY)
      (IF (AND (SYMBOLP (CAR ITEM)) (FBOUNDP (CAR ITEM)))
          (FUNCALL (CAR ITEM) W OFFSETX OFFSETY)
          (WINDOW-CENTER-PRINT W (CAR ITEM) OFFSETX OFFSETY SIZEX
              SIZEY))))

(DEFUN PICK-ONE-SIZE (ITEMS W)
  (LET (WID)
    (DOLIST (ITEM ITEMS)
      (SETQ WID
            (IF WID (MAX WID (CAR (MENU-ITEM-PRINT-SIZE ITEM W)))
                (CAR (MENU-ITEM-PRINT-SIZE ITEM W)))))
    (LIST WID 11)))
(SETF (GET 'PICK-ONE-SIZE 'GLARGUMENTS)
      '((ITEMS (LISTOF MENU-ITEM)) (W WINDOW)))
(SETF (GET 'PICK-ONE-SIZE 'GLFNRESULTTYPE) 'VECTOR)


(DEFUN DRAW-PICK-ONE
       (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
  (LET (ITM)
    (IF (SETQ ITM
              (SOME #'(LAMBDA (GLVAR216)
                        (IF (EQUAL (IF (ATOM GLVAR216) GLVAR216
                                    (CDR GLVAR216))
                                   VAL)
                            GLVAR216))
                    ITEMS))
        (MENU-ITEM-DRAW ITM W OFFSETX OFFSETY SIZEX SIZEY))))

(DEFUN EDIT-PICK-ONE
       (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
  (LET (NEWVAL)
    (IF (<= (LENGTH ITEMS) 3)
        (IF (EQUAL VAL
                   (LET ((SELF (FIRST ITEMS)))
                     (IF (ATOM SELF) SELF (CDR SELF))))
            (SETQ NEWVAL
                  (LET ((SELF (SECOND ITEMS)))
                    (IF (ATOM SELF) SELF (CDR SELF))))
            (IF (EQUAL VAL
                       (LET ((SELF (SECOND ITEMS)))
                         (IF (ATOM SELF) SELF (CDR SELF))))
                (SETQ NEWVAL
                      (IF (THIRD ITEMS)
                          (LET ((SELF (THIRD ITEMS)))
                            (IF (ATOM SELF) SELF (CDR SELF)))
                          (LET ((SELF (FIRST ITEMS)))
                            (IF (ATOM SELF) SELF (CDR SELF)))))
                (SETQ NEWVAL
                      (LET ((SELF (FIRST ITEMS)))
                        (IF (ATOM SELF) SELF (CDR SELF))))))
        (SETQ NEWVAL (MENU ITEMS)))
    (DRAW-PICK-ONE NEWVAL W ITEMS OFFSETX OFFSETY SIZEX SIZEY)
    NEWVAL))

(DEFUN DRAW-BLACK-WHITE
       (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
  (LET (ITM)
    (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX
        (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0)
    (IF (SETQ ITM
              (SOME #'(LAMBDA (GLVAR218)
                        (IF (EQUAL (IF (ATOM GLVAR218) GLVAR218
                                    (CDR GLVAR218))
                                   VAL)
                            GLVAR218))
                    ITEMS))
        (WHEN (EQL (IF (CONSP ITM) (CAR ITM) ITM) 1)
          (LET ((GC (CADDR W)))
            (SETQ *WINDOW-SAVE-FUNCTION*
                  (PROGN
                    (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 1
                        *GC-VALUES*)
                    (XGCVALUES-FUNCTION *GC-VALUES*)))
            (XSETFUNCTION *WINDOW-DISPLAY* GC 6)
            (SETQ *WINDOW-SAVE-FOREGROUND*
                  (PROGN
                    (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 4
                        *GC-VALUES*)
                    (XGCVALUES-FOREGROUND *GC-VALUES*)))
            (XSETFOREGROUND *WINDOW-DISPLAY* GC
                (LOGXOR *WINDOW-SAVE-FOREGROUND*
                        (PROGN
                          (XGETGCVALUES *WINDOW-DISPLAY* (CADDR W) 8
                              *GC-VALUES*)
                          (XGCVALUES-BACKGROUND *GC-VALUES*)))))
          (XFILLRECTANGLE *WINDOW-DISPLAY* (CADR W) (CADDR W) OFFSETX
              (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY)
          (LET ((GC (CADDR W)))
            (XSETFUNCTION *WINDOW-DISPLAY* GC *WINDOW-SAVE-FUNCTION*)
            (XSETFOREGROUND *WINDOW-DISPLAY* GC
                *WINDOW-SAVE-FOREGROUND*))))))

(DEFUN EDIT-BLACK-WHITE
       (ITEMS VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
  (LET (NEWVAL)
    (IF (EQUAL VAL
               (LET ((SELF (FIRST ITEMS)))
                 (IF (ATOM SELF) SELF (CDR SELF))))
        (SETQ NEWVAL
              (LET ((SELF (SECOND ITEMS)))
                (IF (ATOM SELF) SELF (CDR SELF))))
        (IF (EQUAL VAL
                   (LET ((SELF (SECOND ITEMS)))
                     (IF (ATOM SELF) SELF (CDR SELF))))
            (SETQ NEWVAL
                  (LET ((SELF (FIRST ITEMS)))
                    (IF (ATOM SELF) SELF (CDR SELF))))))
    (DRAW-BLACK-WHITE ITEMS NEWVAL W OFFSETX OFFSETY SIZEX SIZEY)
    NEWVAL))

(DEFUN DRAW-INTEGER (VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
  (EDITORS-ANYTHING-PRINT VAL W OFFSETX OFFSETY SIZEX SIZEY))

(DEFUN DRAW-REAL (VAL W &OPTIONAL OFFSETX OFFSETY SIZEX SIZEY)
  (LET (STR NC LNG FMT)
    (IF (NULL SIZEX) (SETQ SIZEX 50))
    (SETQ NC (MAX 1 (TRUNCATE SIZEX 7)))
    (SETQ STR (PRINC-TO-STRING VAL))
    (SETQ LNG (LENGTH STR))
    (IF (> LNG NC)
        (IF (OR (FIND #\. STR :START NC) (FIND #\E STR) (FIND #\L STR))
            (IF (>= NC 8)
                (PROGN
                  (SETQ FMT
                        (CADR (OR (ASSOC NC
                                         '((8 "~8,2E") (9 "~9,2E")
                                           (10 "~10,2E") (11 "~11,2E")
                                           (12 "~12,2E") (13 "~13,2E")
                                           (14 "~14,2E")))
                                  '(15 "~15,2E"))))
                  (SETQ STR (FORMAT NIL FMT VAL)))
                (SETQ STR "*******"))
            (SETQ STR (SUBSEQ STR 0 NC))))
    (EDITORS-ANYTHING-PRINT W STR OFFSETX OFFSETY SIZEX SIZEY)))

(DEFUN EDITORS-ANYTHING-PRINT (OBJ W OFFSETX OFFSETY SIZEX SIZEY)
  (LET (SWIDTH SMAX DX DY)
    (XCLEARAREA *WINDOW-DISPLAY* (CADR W) OFFSETX
        (- (CADDDR W) (1- (+ OFFSETY SIZEY))) SIZEX SIZEY 0)
    (SETQ SWIDTH
          (LET ((SSTR (STRINGIFY (STRINGIFY OBJ))))
            (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))))
    (SETQ SMAX (MIN SWIDTH SIZEX))
    (SETQ DX (* 1/2 (- SIZEX SMAX)))
    (SETQ DY (MAX 0 (+ -5 (* 1/2 SIZEY))))
    (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SMAX))))
      (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W)
          (+ OFFSETX DX) (- (CADDDR W) (+ OFFSETY DY))
          (GET-C-STRING SSTR) (LENGTH SSTR)))))

(DEFUN EDITORS-PRINT-IN-BOX (OBJ W OFFSETX OFFSETY SIZEX SIZEY)
  (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SIZEX))))
    (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX)
        (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY))))
        (GET-C-STRING SSTR) (LENGTH SSTR)))
  (WINDOW-DRAW-BOX-XY W OFFSETX OFFSETY SIZEX SIZEY))

(DEFUN EDITORS-UPDATE-IN-BOX (OBJ W OFFSETX OFFSETY SIZEX SIZEY)
  (LET ((GLVAR229 (+ -6 SIZEY)))
    (XCLEARAREA *WINDOW-DISPLAY* (CADR W) (+ 3 OFFSETX)
        (- (CADDDR W) (1- (+ (+ 3 OFFSETY) GLVAR229))) (+ -6 SIZEX)
        GLVAR229 0))
  (LET ((SSTR (STRINGIFY (EDITORS-STRING-LIMIT OBJ W SIZEX))))
    (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) (+ 4 OFFSETX)
        (- (CADDDR W) (+ OFFSETY (+ -5 (* 1/2 SIZEY))))
        (GET-C-STRING SSTR) (LENGTH SSTR))))

(DEFUN EDITORS-STRING-LIMIT (S W MAX)
  (LET ((STR (STRINGIFY S)) LNG NC)
    (SETQ LNG
          (LET ((SSTR (STRINGIFY STR)))
            (XTEXTWIDTH (SEVENTH W) (GET-C-STRING SSTR) (LENGTH SSTR))))
    (IF (> LNG MAX)
        (PROGN
          (SETQ NC (/ (* (LENGTH STR) MAX) LNG))
          (SUBSEQ STR 0 NC))
        STR)))
(SETF (GET 'EDITORS-STRING-LIMIT 'GLARGUMENTS)
      '((S STRING) (W WINDOW) (MAX INTEGER)))
(SETF (GET 'EDITORS-STRING-LIMIT 'GLFNRESULTTYPE) 'STRING)


(DEFVAR *EDIT-COLOR-MENU-SET* NIL)

(DEFVAR *EDIT-COLOR-RMENU* NIL)

(DEFVAR *EDIT-COLOR-OLD-COLOR* NIL)

(DEFVAR *EDIT-COLOR-MENU-SET*)
(SETF (GET '*EDIT-COLOR-MENU-SET* 'GLISPGLOBALVAR) T)
(SETF (GET '*EDIT-COLOR-MENU-SET* 'GLISPGLOBALVARTYPE) 'MENU-SET)
(DEFVAR *EDIT-COLOR-RMENU*)
(SETF (GET '*EDIT-COLOR-RMENU* 'GLISPGLOBALVAR) T)
(SETF (GET '*EDIT-COLOR-RMENU* 'GLISPGLOBALVARTYPE) 'BARMENU)


(DEFUN EDIT-COLOR-INIT (W)
  (LET (RM GM BM RGB)
    (SETQ RGB (COPY-LIST '(0 0 0)))
    (GLCC 'EDIT-COLOR-RED)
    (GLCC 'EDIT-COLOR-GREEN)
    (GLCC 'EDIT-COLOR-BLUE)
    (SETQ *EDIT-COLOR-MENU-SET* (MENU-SET-CREATE W NIL))
    (SETQ RM
          (BARMENU-CREATE 256 200 10 "" NIL #'EDIT-COLOR-RED (LIST RGB)
              W 120 40 NIL T (COPY-LIST '(65535 0 0))))
    (SETQ *EDIT-COLOR-RMENU* RM)
    (SETQ GM
          (BARMENU-CREATE 256 50 10 "" NIL #'EDIT-COLOR-GREEN
              (LIST RGB) W 170 40 NIL T (COPY-LIST '(0 65535 0))))
    (SETQ BM
          (BARMENU-CREATE 256 250 10 "" NIL #'EDIT-COLOR-BLUE
              (LIST RGB) W 220 40 NIL T (COPY-LIST '(0 0 65535))))
    (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'RED NIL RM "Red"
        '(120 40))
    (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'GREEN NIL GM "Green"
        '(170 40))
    (MENU-SET-ADD-BARMENU *EDIT-COLOR-MENU-SET* 'BLUE NIL BM "Blue"
        '(220 40))
    (MENU-SET-ADD-MENU *EDIT-COLOR-MENU-SET* 'DONE NIL ""
        '(("Done" . DONE)) '(30 150))
    (EDIT-COLOR-RED 200 RGB)
    (EDIT-COLOR-GREEN 50 RGB)
    (EDIT-COLOR-BLUE 250 RGB)))

(DEFUN EDIT-COLOR-RED (VAL COLOR)
  (LET ((W (CADR *EDIT-COLOR-MENU-SET*)))
    (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL))))
      (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 113
          (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR)))
    (SETF (CAR COLOR) (MAX 0 (1- (* 256 VAL))))
    (EDIT-DISPLAY-COLOR W COLOR)))

(DEFUN EDIT-COLOR-GREEN (VAL COLOR)
  (LET ((W (CADR *EDIT-COLOR-MENU-SET*)))
    (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL))))
      (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 163
          (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR)))
    (SETF (CADR COLOR) (MAX 0 (1- (* 256 VAL))))
    (EDIT-DISPLAY-COLOR W COLOR)))

(DEFUN EDIT-COLOR-BLUE (VAL COLOR)
  (LET ((W (CADR *EDIT-COLOR-MENU-SET*)))
    (LET ((SSTR (STRINGIFY (FORMAT NIL "~3D" VAL))))
      (XDRAWIMAGESTRING *WINDOW-DISPLAY* (CADR W) (CADDR W) 213
          (+ -20 (CADDDR W)) (GET-C-STRING SSTR) (LENGTH SSTR)))
    (SETF (CADDR COLOR) (MAX 0 (1- (* 256 VAL))))
    (EDIT-DISPLAY-COLOR W COLOR)))

(DEFUN EDIT-DISPLAY-COLOR (W COLOR)
  (WINDOW-SET-COLOR W COLOR)
  (WINDOW-DRAW-LINE-XY W 50 40 50 100 60)
  (WINDOW-RESET-COLOR W)
  (IF *EDIT-COLOR-OLD-COLOR*
      (WINDOW-FREE-COLOR W *EDIT-COLOR-OLD-COLOR*))
  (SETQ *EDIT-COLOR-OLD-COLOR* *WINDOW-XCOLOR*))

(DEFUN EDIT-COLOR (W)
  (LET (DONE COLOR SEL)
    (IF (OR (NULL *EDIT-COLOR-MENU-SET*)
            (NOT (EQ W (CADR (CADDR (CAADDR *EDIT-COLOR-MENU-SET*))))))
        (EDIT-COLOR-INIT W))
    (SETQ COLOR (FIRST (NTH 16 *EDIT-COLOR-RMENU*)))
    (MENU-SET-DRAW *EDIT-COLOR-MENU-SET*)
    (EDIT-COLOR-RED (TRUNCATE (1+ (CAR COLOR)) 256) COLOR)
    (EDIT-COLOR-GREEN (TRUNCATE (1+ (CADR COLOR)) 256) COLOR)
    (EDIT-COLOR-BLUE (TRUNCATE (1+ (CADDR COLOR)) 256) COLOR)
    (WHILE (NOT DONE)
           (SETQ SEL (MENU-SET-SELECT *EDIT-COLOR-MENU-SET*))
           (SETQ DONE (AND SEL (EQ (FIRST SEL) 'DONE))))
    COLOR))
(SETF (GET 'EDIT-COLOR 'GLARGUMENTS) '((W WINDOW)))
(SETF (GET 'EDIT-COLOR 'GLFNRESULTTYPE) 'RGB)


(DEFUN COLOR-DOT (W X Y COLOR)
  (LET (RGB)
    (SETQ RGB
          (CDR (ASSOC COLOR
                      '((RED 65535 0 0) (YELLOW 65535 57600 0)
                        (GREEN 0 50175 12287) (BLUE 0 0 65535)))))
    (OR RGB (SETQ RGB '(30000 30000 30000)))
    (WINDOW-SET-COLOR W RGB)
    (WINDOW-DRAW-DOT-XY W X Y)
    (WINDOW-RESET-COLOR W)))

(DEFUN COMPILE-EDITORS ()
  (GLCOMPFILES *DIRECTORY* '("glisp/vector.lsp" "X/dwindow.lsp")
      '("glisp/editors.lsp") "glisp/editorstrans.lsp" "glisp/gpl.txt")
  (CF EDITORSTRANS))

(DEFUN COMPILE-EDITORSB ()
  (GLCOMPFILES *DIRECTORY*
      '("glisp/vector.lsp" "X/dwindow.lsp" "X/dwnoopen.lsp")
      '("glisp/editors.lsp") "glisp/editorstrans.lsp" "glisp/gpl.txt"))
