Artifact cd953a2d41ff43bd74af0ef97a068fd84f8be11ac7d341a00e800d2cc298b100:
- File
psl-1983/3-1/glisp/windowcrt.sl
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6317) [annotate] [blame] [check-ins using] [more...]
% WINDOWCRT.SL.11 07 April 83 % derived from <NOVAK>WINDOWCRT.PSL.1 20-Mar-83 12:40:45 % Written by Gordon Novak Jr. % Copyright (c) 1983 Hewlett-Packard (GLOBAL '(MENUSTART)) (GLISPOBJECTS (MENU (LISTOBJECT (ITEMS (LISTOF ATOM)) (WINDOW WINDOW)) MSG ((SELECT MENU-SELECT RESULT ATOM))) (MOUSE ANYTHING) (WINDOW (LISTOBJECT (START VECTOR) (SIZE VECTOR) (TITLE STRING) (LASTFILLEDLINE INTEGER)) PROP ((YPOSITION (LASTFILLEDLINE)) (LEFTMARGIN (1)) (RIGHTMARGIN (WIDTH - 2))) MSG ((CLEAR WINDOW-CLEAR) (OPEN WINDOW-OPEN) (CLOSE WINDOW-CLOSE) (INVERTAREA WINDOW-INVERTAREA OPEN T) (MOVETOXY WINDOW-MOVETOXY OPEN T) (MOVETO WINDOW-MOVETO OPEN T) (PRINTAT WINDOW-PRINTAT OPEN T) (PRETTYPRINTAT WINDOW-PRETTYPRINTAT OPEN T) (UNPRINTAT WINDOW-UNPRINTAT OPEN T) (DRAWLINE WINDOW-DRAWLINE OPEN T) (UNDRAWLINE WINDOW-UNDRAWLINE OPEN T) (CENTEROFFSET WINDOW-CENTEROFFSET OPEN T)) SUPERS (REGION)) ) (GLISPGLOBALS (MOUSE MOUSE) ) (GLISPCONSTANTS (WINDOWCHARWIDTH 1 INTEGER) (WINDOWLINEYSPACING 1 INTEGER) ) (SETQ MOUSE 'MOUSE) (SETQ GEVMENUWINDOW NIL) (SETQ MENUSTART (A VECTOR WITH X = 50 Y = 3)) % edited: 16-Mar-83 15:04 % Select an item from a pop-up menu. (DG MENU-SELECT (M:MENU) (PROG (MAXW I N SAVEESC SAVEGLQ SAVEGCG RESULT) (if ~gevactiveflg then (geventer)) (SAVEGLQ _ GLQUIETFLG) (GLQUIETFLG _ T) (MAXW_0) (FOR X IN M:ITEMS DO (MAXW_ (MAX MAXW X:PNAME:LENGTH))) (IF MAXW > 20 THEN (MAXW _ 20)) (M:WINDOW _ (A WINDOW WITH START = MENUSTART SIZE = (A VECTOR WITH X = (MAXW + 5) *WINDOWCHARWIDTH Y = (MIN (LENGTH M:ITEMS) + 1 19) *WINDOWLINEYSPACING) TITLE = "Menu")) (SEND M:WINDOW OPEN) (I_0) (FOR X IN M:ITEMS DO (I _+ 1) (SEND M:WINDOW PRINTAT (CONCAT (GEVSTRINGIFY I) (concat (IF I<10 THEN " " ELSE " ") (gevstringify X))) (A VECTOR WITH X = 1 Y = M:WINDOW:HEIGHT - I))) (SEND M:WINDOW MOVETOXY 0 -1) (SEND TERMINAL ERASEEOL) LP (SEND M:WINDOW MOVETOXY 0 -1) (SEND TERMINAL PRINTSTRING "Menu: ") (SEND TERMINAL ERASEEOL) (echoon) (N _ (READ)) (echooff) (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) (SPACES 1) (SEND TERMINAL PRINTSTRING "?") (SEND TERMINAL ERASEEOL) (GO LP)) OUT (SEND M:WINDOW CLOSE) (SEND M:WINDOW MOVETOXY 0 -1) (TERPRI) (SEND TERMINAL ERASEEOL) (SETQ GLQUIETFLG SAVEGLQ) (if ~gevactiveflg then (gevexit)) (RETURN RESULT))) % edited: 11-Mar-83 22:42 % Print a character N times. (DG PRINTNC (N:INTEGER C:STRING) (WHILE N > 0 DO (N _- 1) (SEND TERMINAL PRINTCHAR C))) % edited: 16-Mar-83 14:02 % Open a window in a H-19 terminal. (DG WINDOW-CLEAR (W:WINDOW) (PROG (TTL NBL Y NLINES) (NLINES_0) (SEND TERMINAL GRAPHICSMODE) (Y _ W:HEIGHT - 1) (WHILE Y >= W:LASTFILLEDLINE DO (SEND W MOVETOXY 0 Y) (SEND TERMINAL PRINTCHAR LVERTICALBARCHAR) (IF Y<W:TOP THEN (SEND TERMINAL ERASEEOL)) (SEND W MOVETOXY W:WIDTH - 1 Y) (SEND TERMINAL PRINTCHAR RVERTICALBARCHAR) (IF (NLINES _+ 1) >3 THEN (TERPRI) (NLINES_0)) (Y_-1)) (SEND TERMINAL NORMALMODE) (SEND W MOVETOXY 0 -1) (TERPRI) (W:LASTFILLEDLINE _ W:HEIGHT) (SEND W MOVETOXY 0 -1))) (DG WINDOW-CLOSE (W:WINDOW) (PROG (Y NLINES) (Y _ W:HEIGHT) (NLINES _ 0) (WHILE Y >= 0 DO (SEND W MOVETOXY 0 Y) (SEND TERMINAL ERASEEOL) (IF (NLINES _+ 1) > 8 THEN (TERPRI) (NLINES _ 0)) (Y _- 1)) (TERPRI))) % edited: 12-Mar-83 15:22 (DG WINDOW-DRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (IF FROM:Y=TO:Y THEN (SEND W MOVETO FROM) (PRINTNC (TO:X - FROM:X + 1) HORIZONTALLINECHAR) (IF FROM:Y < W:LASTFILLEDLINE THEN (W:LASTFILLEDLINE _ FROM:Y)))) % edited: 12-Mar-83 15:17 (DG WINDOW-INVERTAREA (W:WINDOW AREA:REGION) NIL) % edited: 12-Mar-83 15:18 (DG WINDOW-MOVETO (W:WINDOW POS:VECTOR) (SEND W MOVETOXY POS:X POS:Y)) % edited: 19-Mar-83 20:25 % Move cursor to X-Y position relative to window. (DG WINDOW-MOVETOXY (W:WINDOW X:INTEGER Y:INTEGER) (SEND TERMINAL MOVETOXY X+W:LEFT Y+W:BOTTOM)) % edited: 19-Mar-83 20:39 % Open a window on a H-19 terminal. (DG WINDOW-OPEN (W:WINDOW) (PROG (TTL NBL L) (SEND W MOVETOXY 1 W:HEIGHT) (TTL _ W:TITLE OR " ") (L_TTL:LENGTH) (SEND TERMINAL INVERTVIDEO) (IF TTL:LENGTH > W:WIDTH - 2 THEN (TTL _ (SUBSTRING TTL 1 W:WIDTH - 2))) (NBL _ (W:WIDTH - TTL:LENGTH) /2 - 1) (PRINTNC NBL BLANKCHAR) (SEND TERMINAL PRINTSTRING TTL) (PRINTNC (W:WIDTH - TTL:LENGTH - NBL - 2) BLANKCHAR) (SEND TERMINAL NORMALVIDEO) (TERPRI) (SEND TERMINAL GRAPHICSMODE) (W:LASTFILLEDLINE _ 1) (SEND W MOVETOXY 0 W:HEIGHT) (SEND TERMINAL PRINTCHAR LVERTICALBARCHAR) (SEND W MOVETOXY W:WIDTH - 1 W:HEIGHT) (SEND TERMINAL PRINTCHAR RVERTICALBARCHAR) (SEND W MOVETOXY 0 0) (SEND TERMINAL PRINTCHAR LVERTICALBARCHAR) (PRINTNC W:WIDTH - 2 HORIZONTALBARCHAR) (SEND TERMINAL PRINTCHAR RVERTICALBARCHAR) (send terminal eraseeol) (SEND TERMINAL NORMALMODE) (TERPRI) (SEND W CLEAR) (SEND W MOVETOXY 0 -1))) % edited: 12-Mar-83 17:03 (DG WINDOW-PRETTYPRINTAT (W:WINDOW VALUE POSITION:VECTOR) (SEND W MOVETO POSITION)(RESETLST (RESETSAVE SYSPRETTYFLG T) (RESETSAVE TTYLINELENGTH (W:WIDTH - POSITION:X - 1)) (SHOWPRINT VALUE) (W:LASTFILLEDLINE _ 1))) % edited: 16-Mar-83 14:18 (DG WINDOW-PRINTAT (W:WINDOW S:STRING POS:VECTOR) (IF POS:Y > 0 THEN (SEND W MOVETO POS) (SEND TERMINAL PRINTSTRING S) (TERPRI) (IF POS:Y < W:LASTFILLEDLINE THEN (W:LASTFILLEDLINE _ POS:Y)))) % edited: 12-Mar-83 15:23 (DG WINDOW-UNDRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (IF FROM:Y=TO:Y THEN (SEND W MOVETO FROM) (PRINTNC (TO:X - FROM:X + 1) BLANKCHAR))) % edited: 16-Mar-83 14:19 (DG WINDOW-UNPRINTAT (W:WINDOW S:STRING POS:VECTOR) (IF POS:Y > 0 THEN (SEND W MOVETO POS) (PRINTNC S:LENGTH BLANKCHAR)))