reduce-historical/psl-1983/3-1/glisp/window.sl

% WINDOW.SL.10     28 March 83

% derived from {DSK}WINDOW.PSL;1  4-MAR-83 16:25:00 




(glispconstants

(screenxoffset -255 integer)
(screenyoffset -255 integer)
(screenxscale 256.0 real)
(screenyscale 256.0 real)
)



(GLISPOBJECTS


(MENU (listobject (ITEMS (LISTOF ATOM))
                  (window window))
MSG     ((SELECT MENU-select RESULT ATOM)))


(MOUSE ANYTHING)

(grpos integer
prop ((screenvalue ((self  + screenxoffset) / screenxscale ))))

(grvector (list (x grpos) (y grpos))
  supers (vector))

(WINDOW (listobject (start grvector)
                    (size grvector)
                    (title string)
                    (lastfilledline integer)
                    (lastposition grvector))

PROP    ((leftmargin (left + 1))
         (rightmargin (right - 2)))

MSG     ((CLEAR window-clear)
	 (OPEN window-open)
	 (CLOSE window-close)
         (movetoxy window-movetoxy OPEN T)
	 (INVERTAREA WINDOW-INVERTAREA)
	 (MOVETO WINDOW-MOVETO OPEN T)
	 (PRINTAT WINDOW-PRINTAT OPEN T)
         (printatxy window-printatxy)
	 (PRETTYPRINTAT WINDOW-PRETTYPRINTAT)
	 (UNPRINTAT WINDOW-UNPRINTAT OPEN T)
         (unprintatxy window-unprintatxy)
	 (DRAWLINE WINDOW-DRAWLINE OPEN T)
         (drawlinexy window-drawlinexy OPEN T)
	 (UNDRAWLINE WINDOW-UNDRAWLINE OPEN T)
         (undrawlinexy window-undrawlinexy OPEN T)
	 (CENTEROFFSET WINDOW-CENTEROFFSET))
supers (region) )

)

  

(GLISPGLOBALS
(MOUSE MOUSE)
)

(glispconstants
(windowcharwidth 8 integer)
(windowlineyspacing 20 integer)
)


(setq mouse 'mouse)
(setq gevmenuwindow nil)
(setq menustart (a vector with x = 320 y = 0))

% Initialize graphics routines.
(dg window-init (w:window)
 (prog ()
  (graphics-init)
  (color-display)
  (set-color white)
  (set-line-style solid)
  (set-char-size (quotient 7.0 screenxscale) (quotient 16.0 screenyscale))
))

% Done with graphics
(dg window-term (w:window)
  (prog ()
    (graphics-term)))


% Alias graphics function names without underline characters
(de graphics-init () (graphics_init))
(de graphics-term () (graphics_term))
(de display-init (unit mode) (display_init unit mode))
(de set-color (x) (set_color x))
(de set-line-style (x) (set_line_style x))
(de clear-display () (clear_display))
(de set-char-size (w h) (set_char_size w h))
(de set-text-rot (x y) (set_text_rot x y))
(de set-display-lim (x0 x1 y0 y1) (set_display_lim x0 x1 y0 y1))
(de set-viewport (x0 x1 y0 y1) (set_viewport x0 x1 y0 y1))
(de init-9111 () (init_9111))
(de sample-locator () (sample_locator))
(de await-locator () (await_locator))
(de color-display () (color_display))


% Clear a graphics window.
(dg window-clear (w:window)
)

% Open a graphics window.
(dg window-open (w:window)
(send w drawlinexy w:left w:bottom w:left w:top)
(send w drawlinexy w:left w:top w:right w:top)
(send w drawlinexy w:right w:top w:right w:bottom)
(send w drawlinexy w:right w:bottom w:left w:bottom)
)

% Open a graphics window.
(dg window-close (w:window)
(send w undrawlinexy w:left w:bottom w:left w:top)
(send w undrawlinexy w:left w:top w:right w:top)
(send w undrawlinexy w:right w:top w:right w:bottom)
(send w undrawlinexy w:right w:bottom w:left w:bottom)
)

% GSN  2-MAR-83 16:19 
(DG MOUSE-POSITIONIN (M:MOUSE W:WINDOW)
(GETMOUSESTATE)(A VECTOR WITH X = (LASTMOUSEX W)
		  Y = (LASTMOUSEY W)))


% GSN  2-MAR-83 16:19 
(DG MOUSE-TESTBUTTON (M:MOUSE BUTTON:INTEGER)
(GETMOUSESTATE)(NOT (ZEROP (LOGAND LASTMOUSEBUTTONS BUTTON))))


% GSN  2-FEB-83 13:57 
(DG WINDOW-CENTEROFFSET (W:WINDOW V:VECTOR)
(SEND W:REGION CENTEROFFSET V))


% GSN 28-FEB-83 16:10 
(DG WINDOW-DRAWLINE (W:WINDOW FROM:grVECTOR TO:grVECTOR)
  (send w drawlinexy from:x from:y to:x to:y))

(DG WINDOW-DRAWLINExy (W:WINDOW fromx:grpos fromy:grpos tox:grpos toy:grpos)
  (gdraw white solid fromx:screenvalue fromy:screenvalue
                     tox:screenvalue   toy:screenvalue))

% GSN 28-FEB-83 16:58 
(DG WINDOW-INVERTAREA (W:WINDOW AREA:REGION)
  nil)


% GSN 13-JAN-83 15:29 
(DG WINDOW-MOVETO (W:WINDOW POS:grVECTOR)
  (send w movetoxy pos:x pos:y))

% Move to position specified as separate x and y coordinates.
(dg window-movetoxy (w:window x:grpos y:grpos)
  (gmove x:screenvalue y:screenvalue))

% GSN  2-MAR-83 13:58 
(DG WINDOW-PRETTYPRINTAT (W:WINDOW VALUE POSITION:grVECTOR)
  (set-color white)
  (send w moveto pos)
  (w:lastposition _ position)
  (gtext value))


% GSN 13-JAN-83 16:25 
(DG WINDOW-PRINTAT (W:WINDOW S:STRING POS:grVECTOR)
  (set-color white)
  (send w moveto pos)
  (gtext s))

(DG WINDOW-PRINTATxy (W:WINDOW S:STRING x:grpos y:grpos)
  (set-color white)
  (send w movetoxy x y)
  (gtext s))


% GSN 28-FEB-83 16:11 
(DG WINDOW-UNDRAWLINE (W:WINDOW FROM:VECTOR TO:grVECTOR)
  (send w undrawlinexy from:x from:y to:x to:y))

(DG WINDOW-unDRAWLINExy (W:WINDOW fromx:grpos fromy:grpos tox:grpos toy:grpos)
  (gdraw background solid fromx:screenvalue fromy:screenvalue
                     tox:screenvalue   toy:screenvalue))


% GSN 13-JAN-83 16:24 
(DG WINDOW-UNPRINTAT (W:WINDOW S:STRING POS:grVECTOR)
  (set-color background)
  (send w moveto pos)
  (gtext s))

(DG WINDOW-UNPRINTATxy (W:WINDOW S:STRING x:grpos y:grpos)
  (set-color background)
  (send w movetoxy x y)
  (gtext s))

% Present a pop-up menu and select an item from it.    GSN   14 March 83
(dg menu-select (m:menu)
(prog (maxw i n saveglq result)
  (if ~gevactiveflg then (geventer))
  (saveglq _ glquietflg)
  (glquiteflg _ t)
  (maxw _ 0)
  (for x in m:items do (maxw _ (max maxw x:pname:length)))
  (maxw _ (min maxw 20))
  (m:window _ (a window with start = menustart
                   size = (a vector with x = (maxw + 5)* windowcharwidth
                            y = (min (length m:items) 19) * windowlineyspacing)
                   title = "Menu"))
  (send m:window open)
  (I _ 0)
  (for x in m:items do
    (i _+ 1)
    (send m:window printatxy (concat (gevstringify i)
                                     (concat (if i<10 then "  " else " ")
                                             (gevstringify x)))
           1 (m:window:height - i * windowlineyspacing) ))
lp
  (prin2 "Menu:")
  (n _ (read))
  (if n is integer and n > 0 and n <= (length m:items)
      then (result _ (car (PNth m:items n))) (go out)
      elseif n = 'q then (result _ nil) (go out)
      else (prin1 n)
           (prin2 " ?")
           (terpri)
           (go lp) )
out
  (setq glquietflg saveglq)
  (if ~gevactiveflg then (gevexit))
  (return result)
))