; File: WINDOWS.LSP (C) 12/03/87 Soft Warehouse, Inc.
(SETQ *PRODUCT* "muLISP")
(DEFUN WINDOWS (*COMMAND-LINE*
*FULL-WINDOW* *CURRENT-WINDOW* *WINDOWS* *GCHOOK* *FREE-DATA*
WINDOW PANE EXPN ROW1 COL1 ROW2 COL2 *CURRENT-AREA* *PROMPT*
*OPTIONS* *INVERSE-OPTION* *MAX-LENGTH* *OPTION-COLUMN* *LOCAL-DEMONS*
*UPDATE-FUNCTION* *AUTO-NEWLINE* *INTERRUPT-HOOK* *CURSOR-ON*)
(MAPC 'WRITE-CONSOLE *INIT-SCREEN*) ; Initialize screen
(CURSOR-OFF) ; Turn OFF cursor
(MAKE-WINDOW NIL) ; Take whole window
(CSMEMORY 940 0 T) ; Disable Ctrl-V insert mode toggle
(CSMEMORY 962 6 T) ; Disable Ins insert mode toggle
(SETQ *FULL-WINDOW* (MAKE-WINDOW)
*CURRENT-WINDOW* 0
*GCHOOK* 'GCHOOK)
(GCHOOK)
(SETQ *WINDOWS* (LIST (LIST 0 (LIST NIL) 1 1
(- (CADDR *FULL-WINDOW*) 6)
(- (CADDDR *FULL-WINDOW*) 2) )))
(CLEAR-SCREEN)
(BORDER-WINDOWS)
(WINDOW-STATE *CURRENT-WINDOW* (APPLY *INIT-WINDOW* 'CREATE-WINDOW NIL))
(SETQ *COMMAND-LINE* "")
(UPDATE-WINDOWS)
(SETQ *PROMPT* "")
(LOOP
(SETQ EXPN (CATCH NIL
(APPLY (CAR (WINDOW-STATE)) 'RUN-WINDOW (CDR (WINDOW-STATE))) ))
( ((EQ *THROW-TAG* 'CLOSE-WINDOW) ; Close window
(SETQ WINDOW *CURRENT-WINDOW*
*CURRENT-WINDOW* EXPN)
((NOT (APPLY (CAR (WINDOW-STATE)) 'CLOSE-WINDOW (CDR (WINDOW-STATE))))
(SETQ *CURRENT-WINDOW* WINDOW) )
(SETQ *CURRENT-WINDOW* WINDOW)
((CDR (WINDOW-STATES EXPN))
(WINDOW-STATES EXPN
(DELETE-NTH (WINDOW-STATES EXPN) (WINDOW-PANE EXPN)))
(WINDOW-PANE EXPN
(MIN (WINDOW-PANE EXPN) (SUB1 (LENGTH (WINDOW-STATES EXPN)))))
(UPDATE-WINDOW EXPN) )
(SETQ ROW1 (SUB1 (WINDOW-ROW EXPN))
COL1 (SUB1 (WINDOW-COL EXPN))
ROW2 (+ (WINDOW-ROW EXPN) (WINDOW-ROWS EXPN))
COL2 (+ (WINDOW-COL EXPN) (WINDOW-COLS EXPN))
*WINDOWS* (DELETE-NTH *WINDOWS* EXPN))
( ((< *CURRENT-WINDOW* EXPN))
((ZEROP *CURRENT-WINDOW*))
(SETQ *CURRENT-WINDOW* (SUB1 *CURRENT-WINDOW*)) )
( ((AND (UPPER-RIGHT ROW1 COL1) (LOWER-RIGHT ROW2 COL1))
(LOOP
((= ROW1 ROW2))
(SETQ EXPN (UPPER-RIGHT ROW1 COL1))
(WINDOW-COLS EXPN (- (+ (WINDOW-COLS EXPN) COL2) COL1))
(UPDATE-WINDOW EXPN)
(SETQ ROW1 (+ ROW1 (WINDOW-ROWS EXPN) 1)) ) )
((AND (LOWER-LEFT ROW1 COL1) (LOWER-RIGHT ROW1 COL2))
(LOOP
((= COL1 COL2))
(SETQ EXPN (LOWER-LEFT ROW1 COL1))
(WINDOW-ROWS EXPN (- (+ (WINDOW-ROWS EXPN) ROW2) ROW1))
(UPDATE-WINDOW EXPN)
(SETQ COL1 (+ COL1 (WINDOW-COLS EXPN) 1)) ) )
((AND (UPPER-LEFT ROW1 COL2) (LOWER-LEFT ROW2 COL2))
(LOOP
((= ROW1 ROW2))
(SETQ EXPN (UPPER-LEFT ROW1 COL2))
(WINDOW-COL EXPN (ADD1 COL1))
(WINDOW-COLS EXPN (- (+ (WINDOW-COLS EXPN) COL2) COL1))
(UPDATE-WINDOW EXPN)
(SETQ ROW1 (+ ROW1 (WINDOW-ROWS EXPN) 1)) ) )
((AND (UPPER-LEFT ROW2 COL1) (UPPER-RIGHT ROW2 COL2))
(LOOP
((= COL1 COL2))
(SETQ EXPN (UPPER-LEFT ROW2 COL1))
(WINDOW-ROW EXPN (ADD1 ROW1))
(WINDOW-ROWS EXPN (- (+ (WINDOW-ROWS EXPN) ROW2) ROW1))
(UPDATE-WINDOW EXPN)
(SETQ COL1 (+ COL1 (WINDOW-COLS EXPN) 1)) ) ) )
(BORDER-WINDOWS) )
((EQ *THROW-TAG* 'SWITCH-PANE) ; Switch panes
(WINDOW-PANE *CURRENT-WINDOW* EXPN)
(UPDATE-WINDOW *CURRENT-WINDOW*) )
((EQ *THROW-TAG* 'SWITCH-WINDOW) ; Switch windows
(APPLY 'MAKE-WINDOW *FULL-WINDOW*)
(SET-CURSOR (SUB1 (WINDOW-ROW *CURRENT-WINDOW*))
(SUB1 (WINDOW-COL *CURRENT-WINDOW*)))
(NORMAL-VIDEO (FIRST *WINDOW-COLORS*))
(PRIN1 (ADD1 *CURRENT-WINDOW*))
(SETQ *CURRENT-WINDOW* EXPN
*CURRENT-AREA*)
(SET-CURSOR (SUB1 (WINDOW-ROW *CURRENT-WINDOW*))
(SUB1 (WINDOW-COL *CURRENT-WINDOW*)))
(INVERSE-VIDEO (FIRST *WINDOW-COLORS*))
(PRIN1 (ADD1 *CURRENT-WINDOW*)) )
((EQ *THROW-TAG* 'SPLIT-WINDOW) ; Split window
(WINDOW-PANE (ADD1 *CURRENT-WINDOW*) 0)
(WINDOW-STATES (ADD1 *CURRENT-WINDOW*)
(LIST (COPY-TREE (WINDOW-STATE))))
;If the above 3 lines of code are replaced with the next 2 lines, the new
;window will contain a copy of the hidden panes as well as the top pane.
; (WINDOW-STATES (ADD1 *CURRENT-WINDOW*)
; (COPY-TREE (WINDOW-STATES)))
(BORDER-WINDOWS)
(UPDATE-WINDOW *CURRENT-WINDOW*)
(UPDATE-WINDOW (ADD1 *CURRENT-WINDOW*)) )
((EQ *THROW-TAG* 'DESIGNATE-WINDOW) ; Designate window
((APPLY (CAR (WINDOW-STATE)) 'CLOSE-WINDOW (CDR (WINDOW-STATE)))
(WINDOW-STATE *CURRENT-WINDOW* (APPLY EXPN 'CREATE-WINDOW NIL))
(UPDATE-WINDOW *CURRENT-WINDOW*) ) )
((EQ *THROW-TAG* 'OPEN-PANE) ; Open pane
(WINDOW-STATES *CURRENT-WINDOW*
(INSERT-NTH (APPLY EXPN 'CREATE-WINDOW NIL)
(WINDOW-STATES) (WINDOW-PANE)))
(UPDATE-WINDOW *CURRENT-WINDOW*) )
((EQ *THROW-TAG* 'QUIT-PROGRAM) ; Quit program
(SETQ WINDOW 0)
(LOOP
((= WINDOW (LENGTH *WINDOWS*))
(APPLY 'MAKE-WINDOW *FULL-WINDOW*)
(SET-CURSOR (SUB1 (CADDR *FULL-WINDOW*)) 0)
(SETQ *INSERT-MODE*)
(CURSOR-ON)
(MAPC 'WRITE-CONSOLE *RESET-SCREEN*) ; Reset screen
(SETQ *WINDOW-COLORS* '(7 7 7 7 7 0))
(BORDER-COLOR 0) ;(CLEAR-SCREEN)
(UPDATE-WINDOWS)
(SYSTEM) )
(SETQ PANE 0)
((LOOP
((= PANE (LENGTH (WINDOW-STATES WINDOW))) NIL)
((NOT (APPLY (CAR (NTH PANE (WINDOW-STATES WINDOW))) 'CLOSE-WINDOW
(CDR (NTH PANE (WINDOW-STATES WINDOW))))))
(INCQ PANE) ))
(INCQ WINDOW) ) )
((EQ *THROW-TAG* 'SWITCH-SCREEN) ; Switch screen
(BORDER-WINDOWS)
(UPDATE-WINDOWS)
(SETQ *PROMPT* ""
*OPTIONS*) )
((EQ *THROW-TAG* 'DRIVER)) ; Throw to driver
(THROW *THROW-TAG* EXPN) ) ) ) ; Unrecognized throw
(DEFUN UPDATE-WINDOWS (
WINDOW)
(SETQ WINDOW 0)
(LOOP
((= WINDOW (LENGTH *WINDOWS*)))
(UPDATE-WINDOW WINDOW)
(INCQ WINDOW) ) )
(DEFUN UPDATE-WINDOW (*CURRENT-WINDOW*)
(APPLY (CAR (WINDOW-STATE)) 'UPDATE-WINDOW (CDR (WINDOW-STATE))) )
(DEFUN QUIT-PROGRAM ()
(THROW 'QUIT-PROGRAM) )
; * * * Window Option Functions * * *
(DEFUN CHANGE-WINDOW ()
(EXECUTE-OPTION 'WINDOW '(
("Close" . CLOSE-WINDOW)
("Designate" . DESIGNATE-WINDOW)
("Flip" . NEXT-PANE)
("Goto" . GOTO-WINDOW)
("Next" . NEXT-WINDOW)
("Open" . OPEN-PANE)
("Previous" . LAST-WINDOW)
("Split" "WINDOW SPLIT" (
("Horizontal" . HORIZONTAL-SPLIT)
("Vertical" . VERTICAL-SPLIT) )) )) )
(DEFUN CLOSE-WINDOW (
WINDOW)
((OR (CDR *WINDOWS*) (CDR (WINDOW-STATES)))
(RPLACA (CAR CLOSE-WINDOW) (ADD1 *CURRENT-WINDOW*))
(LOOP
((NOT (MODE-QUERY "WINDOW CLOSE" CLOSE-WINDOW)) NIL)
;((NOT 2) NIL) ;mt
(SETQ WINDOW (PARSE-INTEGER (CAAR CLOSE-WINDOW)))
((AND WINDOW (<= 1 WINDOW (LENGTH *WINDOWS*)))
(THROW 'CLOSE-WINDOW (SUB1 WINDOW)) )
(ERROR-BEEP) ) ) )
(SETQ CLOSE-WINDOW '(("" 0 0 "Enter window number" "Window" 2)))
(DEFUN OPEN-PANE ()
(RPLACA (CAR DESIGNATE-WINDOW) (CAR (WINDOW-STATE)))
(REPLACE-NTH *WINDOW-TYPES* (CAR DESIGNATE-WINDOW) 5)
((MODE-QUERY "WINDOW OPEN" DESIGNATE-WINDOW)
(THROW 'OPEN-PANE (CAAR DESIGNATE-WINDOW)) ) )
(DEFUN DESIGNATE-WINDOW ()
(RPLACA (CAR DESIGNATE-WINDOW) (CAR (WINDOW-STATE)))
(REPLACE-NTH *WINDOW-TYPES* (CAR DESIGNATE-WINDOW) 5)
((MODE-QUERY "WINDOW DESIGNATE" DESIGNATE-WINDOW)
(THROW 'DESIGNATE-WINDOW (CAAR DESIGNATE-WINDOW)) ) )
(SETQ DESIGNATE-WINDOW '(("" 0 0 "Enter window type" "Type" NIL)))
(IF (ATOM *WINDOW-TYPES*) (SETQ *WINDOW-TYPES*))
(DEFUN GOTO-WINDOW (
WINDOW)
(RPLACA (CAR GOTO-WINDOW)
(ADD1 (MOD (ADD1 *CURRENT-WINDOW*) (LENGTH *WINDOWS*))))
(LOOP
((NOT (MODE-QUERY "WINDOW GOTO" GOTO-WINDOW)) NIL)
(SETQ WINDOW (PARSE-INTEGER (CAAR GOTO-WINDOW)))
((AND WINDOW (<= 1 WINDOW (LENGTH *WINDOWS*)))
(THROW 'SWITCH-WINDOW (SUB1 WINDOW)) )
(ERROR-BEEP) ) )
(SETQ GOTO-WINDOW '(("" 0 0 "Enter window number" "Window" 2)))
(DEFUN LAST-WINDOW ()
(THROW 'SWITCH-WINDOW (MOD (SUB1 *CURRENT-WINDOW*) (LENGTH *WINDOWS*))) )
(DEFUN NEXT-WINDOW ()
(THROW 'SWITCH-WINDOW (MOD (ADD1 *CURRENT-WINDOW*) (LENGTH *WINDOWS*))) )
(DEFUN LAST-PANE ()
(THROW 'SWITCH-PANE (MOD (SUB1 (WINDOW-PANE)) (LENGTH (WINDOW-STATES)))) )
(DEFUN NEXT-PANE ()
(THROW 'SWITCH-PANE (MOD (ADD1 (WINDOW-PANE)) (LENGTH (WINDOW-STATES)))) )
(DEFUN HORIZONTAL-SPLIT (
ROW)
(RPLACA (CAR HORIZONTAL-SPLIT) (CEILING (WINDOW-ROWS) 2))
(LOOP
((NOT (MODE-QUERY "WINDOW SPLIT HORIZONTAL" HORIZONTAL-SPLIT)) NIL)
(SETQ ROW (PARSE-INTEGER (CAAR HORIZONTAL-SPLIT)))
((AND ROW (<= 3 ROW (- (WINDOW-ROWS) 2)))
(RPLACD (NTHCDR *CURRENT-WINDOW* *WINDOWS*)
(CONS (COPY-LIST (NTH *CURRENT-WINDOW* *WINDOWS*))
(NTHCDR (ADD1 *CURRENT-WINDOW*) *WINDOWS*)))
(WINDOW-ROWS *CURRENT-WINDOW* (SUB1 ROW))
(WINDOW-ROW (ADD1 *CURRENT-WINDOW*)
(+ (WINDOW-ROW (ADD1 *CURRENT-WINDOW*)) ROW))
(WINDOW-ROWS (ADD1 *CURRENT-WINDOW*)
(- (WINDOW-ROWS (ADD1 *CURRENT-WINDOW*)) ROW))
(THROW 'SPLIT-WINDOW) )
(ERROR-BEEP) ) )
(SETQ HORIZONTAL-SPLIT '(("" 0 0 "Enter line number" "At line" 3)))
(DEFUN VERTICAL-SPLIT (
COL)
(RPLACA (CAR VERTICAL-SPLIT) (CEILING (WINDOW-COLS) 2))
(LOOP
((NOT (MODE-QUERY "WINDOW SPLIT VERTICAL" VERTICAL-SPLIT)) NIL)
;((NOT 45) NIL) ;mt
(SETQ COL (PARSE-INTEGER (CAAR VERTICAL-SPLIT)))
((AND COL (<= 7 COL (- (WINDOW-COLS) 6)))
( ((MEDIUM-RESOLUTION-P))
((EVENP COL))
(DECQ COL) )
(RPLACD (NTHCDR *CURRENT-WINDOW* *WINDOWS*)
(CONS (COPY-LIST (NTH *CURRENT-WINDOW* *WINDOWS*))
(NTHCDR (ADD1 *CURRENT-WINDOW*) *WINDOWS*)))
(WINDOW-COLS *CURRENT-WINDOW* (SUB1 COL))
(WINDOW-COL (ADD1 *CURRENT-WINDOW*)
(+ (WINDOW-COL (ADD1 *CURRENT-WINDOW*)) COL))
(WINDOW-COLS (ADD1 *CURRENT-WINDOW*)
(- (WINDOW-COLS (ADD1 *CURRENT-WINDOW*)) COL))
(THROW 'SPLIT-WINDOW) )
(ERROR-BEEP) ) )
(SETQ VERTICAL-SPLIT '(("" 0 0 "Enter column number" "At column" 3)))
(DEFUN UPPER-LEFT (ROW COL
WINDOW)
(SETQ WINDOW 0)
(LOOP
((= WINDOW (LENGTH *WINDOWS*)) NIL)
((AND (= ROW (SUB1 (WINDOW-ROW WINDOW)))
(= COL (SUB1 (WINDOW-COL WINDOW)))) WINDOW)
(INCQ WINDOW) ) )
(DEFUN UPPER-RIGHT (ROW COL
WINDOW)
(SETQ WINDOW 0)
(LOOP
((= WINDOW (LENGTH *WINDOWS*)) NIL)
((AND (= ROW (SUB1 (WINDOW-ROW WINDOW)))
(= COL (+ (WINDOW-COL WINDOW) (WINDOW-COLS WINDOW)))) WINDOW)
(INCQ WINDOW) ) )
(DEFUN LOWER-LEFT (ROW COL
WINDOW)
(SETQ WINDOW 0)
(LOOP
((= WINDOW (LENGTH *WINDOWS*)) NIL)
((AND (= ROW (+ (WINDOW-ROW WINDOW) (WINDOW-ROWS WINDOW)))
(= COL (SUB1 (WINDOW-COL WINDOW)))) WINDOW)
(INCQ WINDOW) ) )
(DEFUN LOWER-RIGHT (ROW COL
WINDOW)
(SETQ WINDOW 0)
(LOOP
((= WINDOW (LENGTH *WINDOWS*)) NIL)
((AND (= ROW (+ (WINDOW-ROW WINDOW) (WINDOW-ROWS WINDOW)))
(= COL (+ (WINDOW-COL WINDOW) (WINDOW-COLS WINDOW)))) WINDOW)
(INCQ WINDOW) ) )
; * * * Window State Functions * * *
(DEFUN UPDATE-STATE (LST1
LST2)
(SETQ LST2 (WINDOW-STATE))
(LOOP
(POP LST2)
((NULL LST2))
(RPLACA LST2 (EVAL (POP LST1))) ) )
(DEFUN WINDOW-PANE LST
(WINDOW-BOX 0) )
(DEFUN WINDOW-STATES LST
(WINDOW-BOX 1) )
(DEFUN WINDOW-STATE LST
((NULL LST)
(NTH (WINDOW-PANE) (WINDOW-STATES)) )
((CDR LST)
(REPLACE-NTH (CADR LST) (WINDOW-STATES (CAR LST)) (WINDOW-PANE (CAR LST)))
(CADR LST) )
(NTH (WINDOW-PANE (CAR LST)) (WINDOW-STATES (CAR LST))) )
(DEFUN WINDOW-ROW LST
(WINDOW-BOX 2) )
(DEFUN WINDOW-COL LST
(WINDOW-BOX 3) )
(DEFUN WINDOW-ROWS LST
(WINDOW-BOX 4) )
(DEFUN WINDOW-COLS LST
(WINDOW-BOX 5) )
(DEFUN WINDOW-BOX (NUM)
((NULL LST)
(NTH NUM (NTH *CURRENT-WINDOW* *WINDOWS*)) )
((CDR LST)
(REPLACE-NTH (CADR LST) (NTH (CAR LST) *WINDOWS*) NUM)
(CADR LST) )
(NTH NUM (NTH (CAR LST) *WINDOWS*)) )
; * * * Display Option Functions * * *
(DEFUN SET-COLOR (
NUM1 NUM2 NUM3 NUM4 NUM5 NUM6 NUM7 NUM8)
((SETQ MODE (VIDEO-MODE))
((EQ MODE 255) NIL)
(MAPC 'RPLACA SET-COLOR *WINDOW-COLORS*)
(RPLACA (SEVENTH SET-COLOR) (BORDER-COLOR))
(RPLACA (EIGHTH SET-COLOR) (PALETTE-COLOR))
(LOOP
((NOT (MODE-QUERY 'COLOR SET-COLOR)) NIL)
(SETQ NUM1 (PARSE-INTEGER (CAR (FIRST SET-COLOR)))
NUM2 (PARSE-INTEGER (CAR (SECOND SET-COLOR)))
NUM3 (PARSE-INTEGER (CAR (THIRD SET-COLOR)))
NUM4 (PARSE-INTEGER (CAR (FOURTH SET-COLOR)))
NUM5 (PARSE-INTEGER (CAR (FIFTH SET-COLOR)))
NUM6 (PARSE-INTEGER (CAR (SIXTH SET-COLOR)))
NUM7 (PARSE-INTEGER (CAR (SEVENTH SET-COLOR)))
NUM8 (PARSE-INTEGER (CAR (EIGHTH SET-COLOR))) )
((AND (COLORP NUM1) (COLORP NUM2) (COLORP NUM3) (COLORP NUM4)
(COLORP NUM5) (COLORP NUM6) (COLORP NUM7) (COLORP NUM8))
(SETQ *WINDOW-COLORS* (LIST NUM1 NUM2 NUM3 NUM4 NUM5 NUM6))
(BORDER-COLOR NUM7)
(PALETTE-COLOR NUM8)
(THROW 'SWITCH-SCREEN) )
(ERROR-BEEP) ) ) )
(SETQ SET-COLOR '(
("" 0 0 "Enter color number" "Frame" 3)
("" 0 0 "Enter color number" "Working" 3)
("" 0 0 "Enter color number" "Option" 3)
("" 0 0 "Enter color number" "Prompt" 3)
("" 0 0 "Enter color number" "Status" 3)
("" 0 0 "Enter color number" "Bckgrnd" 3)
("" 0 0 "Enter color number" "Border" 3)
("" 0 0 "Enter color number" "Palette" 3) ))
(DEFUN COLORP (NUM)
(AND NUM (<= 0 NUM 63)) )
(DEFUN SET-INSERT ()
(RPLACA (CAR SET-INSERT) (IF *INSERT-MODE* "Insert" "Replace"))
((MODE-QUERY 'MODE SET-INSERT)
(INSERT-STATUS (EQ (CAAR SET-INSERT) "Insert")) ) )
(SETQ SET-INSERT '(("" 0 0 "Select edit mode" "Edit" ("Insert" "Replace"))))
(DEFUN SET-MUTE ()
(MODE-QUERY 'MUTE SET-MUTE) )
(SETQ SET-MUTE '(("No" 0 0 "Mute warning messages" "Active" ("Yes" "No"))))
(DEFUN SET-DISPLAY (
MODE NUM)
((SETQ MODE (VIDEO-MODE))
((= MODE 255) NIL)
(RPLACA (FIRST SET-DISPLAY)
(IF (<= MODE 6) "CGA"
(IF (= MODE 7) "MDA"
(IF (<= MODE 10) "PCjr"
(IF (<= MODE 20) "EGA" "AT&T")))))
(RPLACA (SECOND SET-DISPLAY)
(IF (GRAPHICS-MODE-P MODE) "Graphics" "Text") )
(RPLACA (THIRD SET-DISPLAY)
(IF (OR (MEDIUM-RESOLUTION-P MODE) (= MODE 65)) "Medium" "High") )
((MODE-QUERY 'DISPLAY SET-DISPLAY)
( ((EQ (FIRST (SECOND SET-DISPLAY)) "Text")
(SETQ NUM (IF (EQ (FIRST (FIRST SET-DISPLAY)) "MDA")
7
(IF (EQ (FIRST (THIRD SET-DISPLAY)) "High") 3 1))) )
((EQ (FIRST (FIRST SET-DISPLAY)) "CGA")
(SETQ NUM (IF (EQ (FIRST (THIRD SET-DISPLAY)) "High") 6 4)) )
((EQ (FIRST (FIRST SET-DISPLAY)) "PCjr")
(SETQ NUM (IF (EQ (FIRST (THIRD SET-DISPLAY)) "High") 10 9)) )
((EQ (FIRST (FIRST SET-DISPLAY)) "AT&T")
(SETQ NUM (IF (EQ (FIRST (THIRD SET-DISPLAY)) "High") 64 65)) )
(RPLACA (CAR EGA-DISPLAY)
(IF (MEMBER MODE '(7 15))
"Monochrome"
(IF (= MODE 16) "Enhanced" "Color")))
((MODE-QUERY "DISPLAY MONITOR" EGA-DISPLAY)
((EQ (CAAR EGA-DISPLAY) "Monochrome")
(SETQ NUM 15) )
((EQ (FIRST (THIRD SET-DISPLAY)) "High")
((EQ (CAAR EGA-DISPLAY) "Enhanced")
(SETQ NUM 16) )
(SETQ NUM 14) )
(SETQ NUM 13) )
(RETURN) )
(VIDEO-MODE NUM)
(CURSOR-OFF)
( ((MEDIUM-RESOLUTION-P MODE)
((MEDIUM-RESOLUTION-P))
(RPLACA (CDR *FULL-WINDOW*) (* 2 (CADR *FULL-WINDOW*)))
(RPLACA (CDDDR *FULL-WINDOW*) (* 2 (CADDDR *FULL-WINDOW*)))
(SETQ NUM (LENGTH *WINDOWS*))
(LOOP
((ZEROP NUM))
(DECQ NUM)
(WINDOW-COL NUM (SUB1 (* 2 (WINDOW-COL NUM))))
(WINDOW-COLS NUM (ADD1 (* 2 (WINDOW-COLS NUM))))
( ((= (+ (WINDOW-COL NUM) (WINDOW-COLS NUM))
(- (CADDDR *FULL-WINDOW*) 2))
(WINDOW-COLS NUM (ADD1 (WINDOW-COLS NUM))) ) ) ) )
((MEDIUM-RESOLUTION-P)
(RPLACA (CDR *FULL-WINDOW*) (TRUNCATE (CADR *FULL-WINDOW*) 2))
(RPLACA (CDDDR *FULL-WINDOW*) (CEILING (CADDDR *FULL-WINDOW*) 2))
(SETQ NUM (LENGTH *WINDOWS*))
(LOOP
((ZEROP NUM))
(DECQ NUM)
(WINDOW-COL NUM (CEILING (WINDOW-COL NUM) 2))
(WINDOW-COLS NUM (TRUNCATE (SUB1 (WINDOW-COLS NUM)) 2)) ) ) )
(THROW 'SWITCH-SCREEN) ) ) )
(SETQ SET-DISPLAY '(
("" 0 0 "Select display adapter" "Adapter" ("MDA" "CGA" "EGA" "AT&T" "PCjr"))
("" 0 0 "Select screen mode" "Mode" ("Text" "Graphics"))
("" 0 0 "Select screen resolution" "Res" ("Medium" "High")) ))
(SETQ EGA-DISPLAY '(
("" 0 0 "Select monitor type" "Monitor" ("Color" "Enhanced" "Monochrome")) ))
(DEFUN GO-DOS (
COMMAND)
(SETQ COMMAND "")
;(SETQ COMMAND (PROMPT-INPUT "Dame un comando para ejecutar" ;un solo comando
; (PACK* (DEFAULT-DRIVE) ":\\" (DEFAULT-PATH) "> ") ""))
((EQ *LINE-TERMINATOR* 27))
(STATUS-WINDOW)
(CLEAR-SCREEN)
((EQ COMMAND "")
(SHOW-PROMPT "Type EXIT to return")
(CURSOR-ON)
(MAPC 'WRITE-CONSOLE *RESET-SCREEN*) ; Reset screen
(EXECUTE (GETSET 'COMSPEC))
(MAPC 'WRITE-CONSOLE *INIT-SCREEN*) ; Initialize screen
(CURSOR-OFF)
(THROW 'SWITCH-SCREEN) )
(SHOW-PROMPT "")
(MAKE-WINDOW NIL)
(SET-CURSOR (- (THIRD (MAKE-WINDOW)) 3) 0)
(CURSOR-ON)
(MAPC 'WRITE-CONSOLE *RESET-SCREEN*) ; Reset screen
(EXECUTE (GETSET 'COMSPEC) (PACK* "/C " COMMAND))
(MAPC 'WRITE-CONSOLE *INIT-SCREEN*) ; Initialize screen
(CURSOR-OFF)
(TERPRI 2)
(SETQ *CURRENT-AREA*)
(CONTINUE-PROMPT)
(THROW 'SWITCH-SCREEN)
)
(SETQ *EDIT-TERMINATORS* '(27 13 10))
(DEFUN EXECUTE-OPTION (TITLE OPTIONS
NUM CHAR POSITION)
(LOOP
(SETQ NUM 0)
(LOOP
(LOOP
( ((LISTEN))
(SHOW-OPTIONS TITLE OPTIONS)
((EQ NUM *INVERSE-OPTION*))
(OPTION-WINDOW)
(SHOW-OPTION *INVERSE-OPTION* OPTIONS)
(SETQ *INVERSE-OPTION* NUM
*OPTIONS* OPTIONS)
(INVERSE-VIDEO (THIRD *WINDOW-COLORS*))
(SHOW-OPTION *INVERSE-OPTION* OPTIONS)
(NORMAL-VIDEO (THIRD *WINDOW-COLORS*)) )
((SETQ CHAR (READ-CONSOLE-STATUS)))
(SHOW-PROMPT "Dame la opcion (1er. letra)")
(PROMPT-WINDOW) )
((MEMBER CHAR *EDIT-TERMINATORS*))
((OR (SETQ POSITION (POSITION (CHAR-UPCASE (ASCII CHAR)) OPTIONS
'(LAMBDA (CHAR OPTION) (CHAR= CHAR (CAR OPTION)))))
(AND (ALPHA-CHAR-P (ASCII CHAR))
(SETQ POSITION (POSITION (CHAR-UPCASE (ASCII CHAR)) OPTIONS
'(LAMBDA (CHAR OPTION) (FINDSTRING CHAR (CAR OPTION)))))))
(SETQ NUM POSITION) )
( ((OR (= CHAR 32) (= CHAR 9))
(SETQ NUM (MOD (ADD1 NUM) (LENGTH OPTIONS))) )
((OR (= CHAR 8) (= CHAR 2) (= CHAR -15))
(SETQ NUM (MOD (SUB1 NUM) (LENGTH OPTIONS))) )
(ERROR-BEEP) ) )
((= CHAR 27) NIL)
( ((EQ OPTIONS *OPTIONS*)
(OPTION-WINDOW)
(SHOW-OPTION *INVERSE-OPTION* OPTIONS)
(SETQ *OPTIONS* OPTIONS) ) )
(SETQ *INVERSE-OPTION* NIL
CHAR (CDR (NTH NUM OPTIONS)))
((IF (ATOM CHAR)
(FUNCALL CHAR (CAR (NTH NUM OPTIONS)))
(APPLY 'EXECUTE-OPTION CHAR))) ) )
(DEFUN SHOW-OPTIONS (TITLE OPTIONS)
((EQ OPTIONS *OPTIONS*))
(OPTION-WINDOW)
(CLEAR-SCREEN)
(WRITE-STRING TITLE)
(WRITE-STRING ": ")
(SETQ *OPTIONS* OPTIONS
*OPTION-COLUMN* (COLUMN)
*MAX-LENGTH* (MAX-LENGTH OPTIONS)
*INVERSE-OPTION*)
(LOOP
(LOOP
(WRITE-STRING (SUBSTRING (CAAR OPTIONS) 0 (SUB1 *MAX-LENGTH*)))
(POP OPTIONS)
((ATOM OPTIONS))
((>= (+ (COLUMN) (MIN *MAX-LENGTH* (LENGTH (CAAR OPTIONS))))
(CADDDR *FULL-WINDOW*)))
(SPACES 1) )
((ATOM OPTIONS))
(TERPRI)
(SPACES *OPTION-COLUMN*) ) )
(DEFUN MAX-LENGTH (OPTIONS
ROW COL MAX LST)
(SETQ MAX (REDUCE '(LAMBDA (NUM OPTION)
(MAX NUM (LENGTH (CAR OPTION))) ) OPTIONS 0))
(LOOP
(SETQ LST OPTIONS
ROW 0)
((LOOP
((= ROW (IF (< (CADDDR *FULL-WINDOW*) 75) 3 2)) NIL)
(SETQ COL *OPTION-COLUMN*)
(LOOP
((ATOM LST)
(RETURN MAX) )
(SETQ COL (+ COL (MIN MAX (LENGTH (CAAR LST))) 1))
((> COL (CADDDR *FULL-WINDOW*)))
(POP LST) )
(INCQ ROW) ))
(DECQ MAX) ) )
(DEFUN SHOW-OPTION (NUM OPTIONS
ROW COL)
((NOT NUM))
(SETQ ROW 0)
(LOOP
(SETQ COL *OPTION-COLUMN*)
(LOOP
((ZEROP NUM)
(SET-CURSOR ROW COL)
(WRITE-STRING (SUBSTRING (CAAR OPTIONS) 0 (SUB1 *MAX-LENGTH*)))
(RETURN) )
(SETQ COL (+ COL (MIN *MAX-LENGTH* (LENGTH (CAAR OPTIONS)))))
(DECQ NUM)
(POP OPTIONS)
((>= (+ COL (MIN *MAX-LENGTH* (LENGTH (CAAR OPTIONS))))
(CADDDR *FULL-WINDOW*)))
(INCQ COL) )
(INCQ ROW) ) )
(DEFUN MODE-QUERY1 (TITLE let) ;mt
(SHOW-PROMPT "EJ: (b 1 1 b)<enter>")
(OPTION-WINDOW)
(CLEAR-SCREEN)
(WRITE-STRING TITLE)
(WRITE-STRING ": ")
(CURSOR-ON)
(SETQ MT_ENTRADA (READ))
)
(DEFUN MODE-QUERY (TITLE OPTIONS
NUM COLUMN QUERY)
(OPTION-WINDOW)
(CLEAR-SCREEN)
(WRITE-STRING TITLE)
(WRITE-STRING ": ")
(SETQ COLUMN (IF (< (CADDDR *FULL-WINDOW*) 75) 2 (COLUMN))
NUM 0)
(LOOP
((= NUM (LENGTH OPTIONS)))
(SETQ QUERY (NTH NUM OPTIONS))
( ((> (+ (COLUMN) (LENGTH (FIFTH QUERY)) 2 (QUERY-LENGTH (SIXTH QUERY)))
(CADDDR *FULL-WINDOW*))
(SET-CURSOR (ADD1 (ROW)) COLUMN) ) )
( ((= (COLUMN) 0)
(SET-CURSOR (ROW) COLUMN) ) )
(WRITE-STRING (FIFTH QUERY))
(IF (AND (NEQ (FIFTH QUERY) "")
(EQ (FIFTH QUERY) (STRING-RIGHT-TRIM " " (FIFTH QUERY))))
(WRITE-STRING ": "))
(RPLACA (CDR QUERY) (ROW))
(RPLACA (CDDR QUERY) (COLUMN))
( ((INTEGERP (SIXTH QUERY))
(WRITE-STRING (SUBSTRING (MAKE-STRING (CAR QUERY)) 0
(SUB1 (SIXTH QUERY)))) )
(SHOW-MODES (CAR QUERY) (SIXTH QUERY)) )
(SET-CURSOR (ROW) (+ (CADDR QUERY) (QUERY-LENGTH (SIXTH QUERY)) 1))
(INCQ NUM) )
(SETQ NUM 0)
(LOOP
(SETQ QUERY (NTH NUM OPTIONS))
(RPLACA QUERY (APPLY 'MAKE-QUERY QUERY))
((MEMBER *LINE-TERMINATOR* *EDIT-TERMINATORS*)
(NEQ *LINE-TERMINATOR* 27) )
((AND (ZEROP *LINE-TERMINATOR*) (EQ (LENGTH OPTIONS) 1)))
( ((OR (EQ *LINE-TERMINATOR* 9) (ZEROP *LINE-TERMINATOR*))
(SETQ NUM (MOD (ADD1 NUM) (LENGTH OPTIONS))) )
((OR (EQ *LINE-TERMINATOR* 2) (EQ *LINE-TERMINATOR* -15))
(SETQ NUM (MOD (SUB1 NUM) (LENGTH OPTIONS))) ) ) ) )
(DEFUN MAKE-QUERY (DEFAULT ROW COLUMN PROMPT TITLE OPTIONS
POSITION NUM )
(SHOW-PROMPT PROMPT)
((INTEGERP OPTIONS)
(OPTION-WINDOW)
(SET-CURSOR ROW COLUMN)
(SETQ NUM (CSMEMORY 914 0 T)) ; Disable tabbing
(PROG1 (LINE-EDITOR DEFAULT '(27 13 10 9 2 -15) 0 0 OPTIONS)
(CSMEMORY 914 NUM T) ) ) ; Enable tabbing
(SETQ NUM (POSITION DEFAULT OPTIONS))
(LOOP
(OPTION-WINDOW)
(SET-CURSOR ROW (SUB1 COLUMN))
(SPACES 1)
(SETQ *LINE-TERMINATOR* (SELECT-OPTION NUM OPTIONS))
((MEMBER *LINE-TERMINATOR* '(27 13 10 9 2 -15)))
((OR (SETQ POSITION (POSITION (CHAR-UPCASE (ASCII *LINE-TERMINATOR*))
OPTIONS 'CHAR=))
(AND (ALPHA-CHAR-P (ASCII *LINE-TERMINATOR*))
(SETQ POSITION (POSITION (CHAR-UPCASE (ASCII *LINE-TERMINATOR*))
OPTIONS 'FINDSTRING))))
(SETQ NUM POSITION
*LINE-TERMINATOR* 0) )
( ((= *LINE-TERMINATOR* 32)
(SETQ NUM (MOD (ADD1 NUM) (LENGTH OPTIONS))) )
((= *LINE-TERMINATOR* 8)
(SETQ NUM (MOD (SUB1 NUM) (LENGTH OPTIONS))) )
(ERROR-BEEP) ) )
(SETQ DEFAULT (NTH NUM OPTIONS))
(OPTION-WINDOW)
(SET-CURSOR ROW COLUMN)
(SHOW-MODES DEFAULT OPTIONS)
DEFAULT )
(DEFUN SHOW-MODES (DEFAULT OPTIONS
NUM)
(SETQ NUM 0)
(LOOP
((ATOM OPTIONS))
( ((EQUAL DEFAULT (CAR OPTIONS))
(WRITE-BYTE 8)
(WRITE-STRING "(")
(WRITE-STRING (POP OPTIONS))
(WRITE-STRING ")") )
(WRITE-STRING (POP OPTIONS))
(SPACES 1) )
(INCQ NUM) ) )
(DEFUN SELECT-OPTION (DEFAULT OPTIONS
MODE NUM)
(SETQ NUM 0)
(LOOP
((ATOM OPTIONS))
(SETQ MODE (POP OPTIONS))
( ((EQ NUM DEFAULT)
(INVERSE-VIDEO (THIRD *WINDOW-COLORS*))
(WRITE-STRING MODE)
(NORMAL-VIDEO (THIRD *WINDOW-COLORS*)) )
(WRITE-STRING MODE) )
( ((= (COLUMN) 0))
(SPACES 1) )
(INCQ NUM) )
(PROMPT-WINDOW)
(LOOP
((READ-CONSOLE-STATUS)) ) )
(DEFUN QUERY-LENGTH (OPTIONS
NUM)
((INTEGERP OPTIONS)
(ADD1 OPTIONS) )
(SETQ NUM 0)
(LOOP
((ATOM OPTIONS) NUM)
(SETQ NUM (+ NUM (LENGTH (POP OPTIONS)) 1)) ) )
(DEFUN BORDER-WINDOWS (
WINDOW ROW1 COL1 ROW2 COL2)
(APPLY 'MAKE-WINDOW *FULL-WINDOW*)
(NORMAL-VIDEO (FIRST *WINDOW-COLORS*))
(HORIZONTAL-BORDER 0 1 (- (CADDDR *FULL-WINDOW*) 2))
(VERTICAL-BORDER 1 0 (- (CADDR *FULL-WINDOW*) 6))
(SETQ WINDOW 0
*CURRENT-AREA*)
(LOOP
((= WINDOW (LENGTH *WINDOWS*)))
(SETQ ROW1 (SUB1 (WINDOW-ROW WINDOW))
COL1 (SUB1 (WINDOW-COL WINDOW))
ROW2 (+ (WINDOW-ROW WINDOW) (WINDOW-ROWS WINDOW))
COL2 (+ (WINDOW-COL WINDOW) (WINDOW-COLS WINDOW)))
(SET-CURSOR ROW1 COL1)
( ((= WINDOW *CURRENT-WINDOW*)
(INVERSE-VIDEO (FIRST *WINDOW-COLORS*))
(PRIN1 (ADD1 WINDOW))
(NORMAL-VIDEO (FIRST *WINDOW-COLORS*)) )
(PRIN1 (ADD1 WINDOW)) )
(SET-CURSOR ROW1 COL2)
( ((UPPER-LEFT ROW1 COL2))
((LOWER-RIGHT ROW1 COL2)
(WRITE-BORDER 9) )
(WRITE-BORDER 2) )
(SET-CURSOR ROW2 COL1)
( ((UPPER-LEFT ROW2 COL1))
((LOWER-RIGHT ROW2 COL1)
(WRITE-BORDER 6) )
(WRITE-BORDER 4) )
(SETQ ROW1 (ADD1 ROW1)
COL1 (ADD1 COL1))
( ((AND (= ROW2 (- (CADDR *FULL-WINDOW*) 5)) (MEDIUM-RESOLUTION-P)))
(HORIZONTAL-BORDER ROW2 COL1 (- COL2 COL1)) )
(VERTICAL-BORDER ROW1 COL2 (- ROW2 ROW1))
(INCQ WINDOW) )
((MEDIUM-RESOLUTION-P))
(SET-CURSOR ROW2 COL2)
(WRITE-BORDER 5) )
(DEFUN HORIZONTAL-BORDER (ROW COL COLS)
(SET-CURSOR ROW COL)
(WRITE-BORDER 0 COLS) )
(DEFUN VERTICAL-BORDER (ROW COL ROWS)
(SETQ ROWS (+ ROW ROWS))
(LOOP
((= ROW ROWS))
(SET-CURSOR ROW COL)
(WRITE-BORDER 7)
(INCQ ROW) ) )
(DEFUN WRITE-BORDER (CHAR NUM)
(WRITE-BYTE (NTH CHAR *BORDER-CHARS*) NUM) )
(DEFUN CURRENT-WINDOW ()
(NORMAL-VIDEO (SECOND *WINDOW-COLORS*))
((EQUAL *CURRENT-AREA*
(SETQ *CURRENT-AREA* (CDDR (NTH *CURRENT-WINDOW* *WINDOWS*)))))
(MAKE-WINDOW (+ (CAR *FULL-WINDOW*) (WINDOW-ROW))
(+ (CADR *FULL-WINDOW*) (WINDOW-COL))
(WINDOW-ROWS)
(WINDOW-COLS)) )
(DEFUN OPTION-WINDOW (
ROWS)
(NORMAL-VIDEO (THIRD *WINDOW-COLORS*))
(SETQ *OPTIONS*)
((EQ *CURRENT-AREA* (SETQ *CURRENT-AREA* 'OPTION-WINDOW)))
(SETQ ROWS (IF (< (CADDDR *FULL-WINDOW*) 75) 3 2 ))
(MAKE-WINDOW (- (+ (CAR *FULL-WINDOW*) (CADDR *FULL-WINDOW*)) ROWS 2)
(CADR *FULL-WINDOW*)
ROWS
(CADDDR *FULL-WINDOW*)) )
(DEFUN PROMPT-WINDOW ()
((EQ *CURRENT-AREA* (SETQ *CURRENT-AREA* 'PROMPT-WINDOW)))
(NORMAL-VIDEO (FOURTH *WINDOW-COLORS*))
(MAKE-WINDOW (+ (CAR *FULL-WINDOW*) (CADDR *FULL-WINDOW*) -2)
(CADR *FULL-WINDOW*)
1
(CADDDR *FULL-WINDOW*)) )
(DEFUN STATUS-WINDOW ()
((EQ *CURRENT-AREA* (SETQ *CURRENT-AREA* 'STATUS-WINDOW)))
(NORMAL-VIDEO (FIFTH *WINDOW-COLORS*))
(MAKE-WINDOW (+ (CAR *FULL-WINDOW*) (CADDR *FULL-WINDOW*) -1)
(CADR *FULL-WINDOW*)
1
(CADDDR *FULL-WINDOW*)) )
(DEFUN GRAPHICS-MODE-P (MODE)
(IF (NOT MODE)
(SETQ MODE (VIDEO-MODE)) )
((NUMBERP MODE)
((>= MODE 4)
(/= MODE 7) ) ) )
(DEFUN MEDIUM-RESOLUTION-P (MODE)
(IF (NOT MODE)
(SETQ MODE (VIDEO-MODE)) )
(MEMBER MODE '(0 1 4 5 9 13)) )
(DEFUN CONTINUE-PROMPT (
BYTE)
(CLEAR-INPUT T)
(LOOP
(SETQ BYTE (PROMPT-READ-BYTE "Presiona alguna tecla para continuar"))
((NEQ BYTE 19) BYTE) ) )
(DEFUN PROMPT-YN (PROMPT
BYTE )
(LOOP
(SETQ BYTE (PROMPT-READ-BYTE PROMPT))
((MEMBER BYTE '(83 115 25))
(WRITE-BYTE 83 NIL T)
(SETQ *PROMPT*)
T )
((MEMBER BYTE '(78 110 14))
(WRITE-BYTE 78 NIL T)
(SETQ *PROMPT*) )
(ERROR-BEEP) ) )
(DEFUN PROMPT-READ-BYTE (PROMPT)
(PROMPT-WINDOW)
( ((EQ PROMPT *PROMPT*)
(SET-CURSOR 0 (LENGTH *PROMPT*)) )
(CLEAR-SCREEN)
(SETQ *PROMPT* (WRITE-STRING PROMPT T)) )
(READ-CONSOLE-BYTE) )
(DEFUN SHOW-PROMPT (PROMPT)
((OR (NULL PROMPT) (EQ PROMPT *PROMPT*)))
(PROMPT-WINDOW)
(CLEAR-SCREEN)
(SETQ *PROMPT* (WRITE-STRING PROMPT T))
(SET-CURSOR 0 0) )
(DEFUN ERROR-BEEP ()
((EQUAL (CAAR SET-MUTE) "Yes"))
(CLEAR-INPUT)
((EQ (CSMEMORY 855) 2)
(TONE 1000 100) )
(WRITE-BYTE 7) )
(DEFUN MAKE-STRING (EXPN)
((SYMBOLP EXPN) EXPN)
(PACK* EXPN) )
(IF (EQ *DEFAULT-TYPE* '*DEFAULT-TYPE*) (SETQ *DEFAULT-TYPE* ""))
(DEFUN PROMPT-TEXT-FILE (COMMAND FILE-NAME)
(SETQ FILE-NAME (STRING-UPCASE
(PROMPT-INPUT "Enter file name" COMMAND FILE-NAME)))
((OR (EQ *LINE-TERMINATOR* 27) (EQ FILE-NAME "")) "")
(NORMALIZE-FILE-NAME FILE-NAME *DEFAULT-TYPE*) )
(DEFUN NORMALIZE-FILE-NAME (FILE-NAME DEFAULT-TYPE
NUM)
(SETQ NUM (IF (EQ (CHAR FILE-NAME 1) '\:) 2 0))
( ((EQ (CHAR FILE-NAME NUM) '\.)
(INCQ NUM)
((EQ (CHAR FILE-NAME NUM) '\.)
(INCQ NUM) ) ) )
((SETQ NUM (FINDSTRING '\. FILE-NAME NUM))
(SUBSTRING FILE-NAME 0 (+ NUM 3)) )
(PACK* FILE-NAME '\. DEFAULT-TYPE) )
(DEFUN PROMPT-INPUT (PROMPT COMMAND DEFAULT)
(SHOW-PROMPT PROMPT)
(OPTION-WINDOW)
(CLEAR-SCREEN)
(WRITE-STRING COMMAND T)
(LINE-EDITOR DEFAULT *EDIT-TERMINATORS* 0 0
(- (CADDDR *FULL-WINDOW*) (COLUMN) 1)) )
(DEFUN LINE-EDITOR (TEXT TERMINATORS *LINE-POINT* *LINE-COLUMN* COLS
ROW COL )
(SETQ ROW (ROW)
COL (COLUMN))
(LOOP
(OPTION-WINDOW)
(SET-CURSOR ROW COL)
(CURSOR-ON)
(SETQ TEXT (LINE-EDIT TEXT *LINE-POINT* *LINE-COLUMN* COLS))
(CURSOR-OFF)
((MEMBER *LINE-TERMINATOR* TERMINATORS)
(STRING-TRIM " " TEXT) )
( ((MEMBER *LINE-TERMINATOR* '(11 15)))
(DEMON-BYTE *LINE-TERMINATOR*) ) ) )
(SETQ *FREE-STATUS* NIL)
(DEFUN GCHOOK (
ROW COL FOREGROUND-COLOR BACKGROUND-COLOR WINDOW
*CURRENT-AREA* *OUTPUT-FILE*)
( ((ZEROP (SETQ *FREE-DATA* (DSMEMORY 8 NIL T)))
(SETQ *FREE-DATA* 65536) ) )
(SETQ *FREE-DATA* (TRUNCATE (* 100 (- (+ (- *FREE-DATA* (DSMEMORY 6 NIL T))
(DSMEMORY 2 NIL T)) (DSMEMORY 0 NIL T))) *FREE-DATA*)
*FREE-DATA* (MIN *FREE-DATA* (TRUNCATE (* 100 (DSMEMORY 44 NIL T))
(- 65536 (DSMEMORY 46 NIL T)))))
((NOT *FREE-STATUS*))
(SETQ ROW (ROW)
COL (COLUMN)
FOREGROUND-COLOR (FOREGROUND-COLOR)
BACKGROUND-COLOR (BACKGROUND-COLOR)
WINDOW (MAKE-WINDOW))
(FUNCALL *FREE-STATUS*)
(APPLY 'MAKE-WINDOW WINDOW)
(FOREGROUND-COLOR FOREGROUND-COLOR)
(BACKGROUND-COLOR BACKGROUND-COLOR)
(SET-CURSOR ROW COL) )
(DEFUN CLEAR-STATUS (PROMPT)
(STATUS-WINDOW)
(CLEAR-SCREEN)
(INSERT-STATUS *INSERT-MODE*)
(SET-CURSOR 0 (- (CADDDR *FULL-WINDOW*) (LENGTH PROMPT)))
(WRITE-STRING PROMPT T)
(SET-CURSOR 0 0)
((< (CADDDR *FULL-WINDOW*) 75))
(SET-CURSOR 0 (- (- (CADDDR *FULL-WINDOW*) (LENGTH PROMPT))
(ADD1 (LENGTH *PRODUCT*))))
(WRITE-STRING *PRODUCT* T)
(SET-CURSOR 0 0) )
(DEFUN TOGGLE-INSERT ()
(INSERT-STATUS (NOT *INSERT-MODE*)) )
(DEFUN INSERT-STATUS (MODE)
(SETQ *INSERT-MODE* MODE)
((EQ (CAR (WINDOW-STATE)) "Graph"))
(STATUS-WINDOW)
(SET-CURSOR 0 (TRUNCATE (* 2 (CADDDR *FULL-WINDOW*)) 3))
((NOT *INSERT-MODE*)
(SPACES 6) )
(WRITE-STRING "Insert") )
(DEFUN PARSE-INTEGER (SYM RADIX
CHAR SIGN N )
(SETQ *STRING-INDEX* 0)
(LOOP
((NULL (SETQ CHAR (CHAR SYM *STRING-INDEX*))) NIL)
((NEQ CHAR '| |)
(SETQ SIGN 1)
( ((EQ CHAR '+)
(INCQ *STRING-INDEX*) )
((EQ CHAR '-)
(SETQ SIGN -1)
(INCQ *STRING-INDEX*) ) )
((SETQ CHAR (CHAR SYM *STRING-INDEX*))
((SETQ N (DIGIT-CHAR-P CHAR RADIX))
(IF (NULL RADIX) (SETQ RADIX 10))
(LOOP
(INCQ *STRING-INDEX*)
((NULL (SETQ CHAR (CHAR SYM *STRING-INDEX*))))
((NOT (SETQ CHAR (DIGIT-CHAR-P CHAR RADIX))))
(SETQ N (+ (* N RADIX) CHAR)) )
(* SIGN N) ) ) )
(INCQ *STRING-INDEX*) ) )
(DEFUN READ-CONSOLE-STATUS (
*INPUT-FILE*)
(LOOP
(IF *UPDATE-FUNCTION* (FUNCALL *UPDATE-FUNCTION*))
((NOT (LISTEN)) NIL)
((DEMON-BYTE (READ-CONSOLE-BYTE))) ) )
(DEFUN READ-CONSOLE-BYTE (
*INPUT-FILE*)
(CURSOR-ON)
(PROG1 (CONSOLE-BYTE (READ-BYTE))
(CURSOR-OFF)) )
(DEFUN DEMON-BYTE (BYTE
DEMON)
(SETQ BYTE (NORMALIZE-BYTE BYTE))
((SETQ DEMON (OR (ASSOC BYTE *LOCAL-DEMONS*) (ASSOC BYTE *GLOBAL-DEMONS*)))
(FUNCALL (CDR DEMON) BYTE)
(IF *UPDATE-FUNCTION* (FUNCALL *UPDATE-FUNCTION*))
NIL )
BYTE )
(DEFUN NORMALIZE-BYTE (BYTE)
( ((<= -103 BYTE -94) ;Ctrl Fx --> Shift Fx
(SETQ BYTE (+ BYTE 10)) )
((<= -113 BYTE -104) ;Alt Fx --> Shift Fx
(SETQ BYTE (+ BYTE 20)) ) )
((CDR (ASSOC BYTE *CURSOR-KEYS*)))
BYTE )
(SETQ *CURSOR-KEYS* '(
(-72 . 5) ;Up arrow Ctrl-E
(-80 . 24) ;Down arrow Ctrl-X
(-75 . 19) ;<-- Ctrl-S
(-77 . 4) ;--> Ctrl-D
(-73 . 18) ;PgUp Ctrl-R
(-81 . 3) ;PgDn Ctrl-C
(-115 . 1) ;Ctrl <-- Ctrl-A
(-116 . 6) ;Ctrl --> Ctrl-F
(-82 . 22) ;Ins Ctrl-V
(-83 . 7) )) ;Del Ctrl-G
(SETQ *GLOBAL-DEMONS* '(
(22 . TOGGLE-INSERT) ;Ctrl-V (Ins)
(-59 . NEXT-WINDOW) ;F1
(-84 . LAST-WINDOW) ;Shift F1
(-60 . NEXT-PANE) ;F2
(-85 . LAST-PANE) )) ;Shift F2
; * * * Computer customization section * * *
(SETQ *INIT-SCREEN* NIL) ;Generic values
(SETQ *RESET-SCREEN* NIL)
(SETQ *BORDER-CHARS* '(45 32 32 45 32 32 45 124 124 124 43))
(MOVD 'IDENTITY 'NORMAL-VIDEO)
(MOVD 'IDENTITY 'INVERSE-VIDEO)
(MOVD 'WRITE-STRING 'BLINK-WRITE-STRING)
(MOVD 'IDENTITY 'CURSOR-ON)
(MOVD 'IDENTITY 'CURSOR-OFF)
(MOVD 'IDENTITY 'CONSOLE-BYTE)
(DEFUN WRITE-CONSOLE (BYTE)
(REGISTER 0 512)
(REGISTER 3 BYTE)
(INTERRUPT 33) )
(IF (EQ (CSMEMORY 855) 2) ;IBM PC?
(PROGN
(SETQ *BORDER-CHARS* '(205 213 184 209 212 190 207 179 198 181 216))
(SETQ *WINDOW-COLORS* '(3 15 7 13 11 0))
(DEFUN NORMAL-VIDEO (COLOR)
( ((ZEROP COLOR))
((>= COLOR 15))
((EQ (VIDEO-MODE) 7)
(SETQ COLOR 7) ) )
(FOREGROUND-COLOR COLOR)
(BACKGROUND-COLOR (LOGAND (SIXTH *WINDOW-COLORS*)
(IF (GRAPHICS-MODE-P) 15 7))) )
(DEFUN INVERSE-VIDEO (COLOR)
( ((ZEROP COLOR))
((>= COLOR 15))
((EQ (VIDEO-MODE) 7)
(SETQ COLOR 7) ) )
(FOREGROUND-COLOR (SIXTH *WINDOW-COLORS*))
(BACKGROUND-COLOR (LOGAND COLOR (IF (GRAPHICS-MODE-P) 15 7))) )
(DEFUN BLINK-WRITE-STRING (STRING
*BLINK*)
(SETQ COLOR (FOREGROUND-COLOR))
((EQ (VIDEO-MODE) 15)
(NORMAL-VIDEO 4)
(WRITE-STRING STRING) ;Write string
(NORMAL-VIDEO COLOR) )
((GRAPHICS-MODE-P)
(INVERSE-VIDEO COLOR)
(WRITE-STRING STRING) ;Write string
(NORMAL-VIDEO COLOR) )
(SETQ *BLINK* T) ;Turn blink mode ON
(WRITE-STRING STRING) ) ;Write string
(DEFUN CURSOR-ON () ;Turn cursor ON
((NOT *INSERT-MODE*)
(CURSOR-LINES NIL) )
((MEMBER (VIDEO-MODE) '(7 15 16))
(CURSOR-LINES 9 12) )
(CURSOR-LINES 5 7) )
(DEFUN CURSOR-OFF () ;Turn cursor OFF
((NOT *CURSOR-ON*)
(CURSOR-LINES 14 0) ) )
(DEFUN CONSOLE-BYTE (BYTE)
((AND (= BYTE 255) (LISTEN)) ;Extended function key?
(- (READ-BYTE)) )
BYTE )
))
(IF (<= 9 (CSMEMORY 855) 10) ;NEC PC-9801 or Fujitsu?
(PROGN
(SETQ *BORDER-CHARS* '(149 152 153 145 154 155 144 150 147 146 143))
(DEFUN WRITE-BORDER (CHAR NUM)
(MAPC 'WRITE-CONSOLE '(27 41 51)) ;Activate graphics mode
(WRITE-BYTE (NTH CHAR *BORDER-CHARS*) NUM)
(MAPC 'WRITE-CONSOLE '(27 41 48)) ) ;Activate kanji mode
(DEFUN CURSOR-ON () ;Turn cursor ON
(MAPC 'WRITE-CONSOLE '(27 91 62 53 108)) )
(DEFUN CURSOR-OFF () ;Turn cursor OFF
((NOT *CURSOR-ON*)
(MAPC 'WRITE-CONSOLE '(27 91 62 53 104)) ) )
(DEFUN CONSOLE-BYTE (BYTE)
((AND (EQ BYTE 27) (LISTEN)) ;Function key?
(SETQ BYTE (READ-BYTE))
((CDR (ASSOC BYTE '(
(83 . -59) ;F1
(84 . -60) ;F2
(85 . -61) ;F3
(86 . -62) ;F4
(87 . -63) ;F5
(69 . -64) ;F6
(74 . -65) ;F7
; (80 . -66) ;F8
(81 . -67) ;F9
(68 . -83) ;Del
(80 . -82) )))) ;Ins
(UNREAD-CHAR)
27 )
((EQ BYTE 127) -68) ;F10
BYTE )
))
(IF (OR (<= 3 (CSMEMORY 855) 4) ;ANSI or TI-PC?
(<= 8 (CSMEMORY 855) 10)) ;NEC XA, 9801 or Fujitsu?
(PROGN
(DEFUN NORMAL-VIDEO ()
(MAPC 'WRITE-CONSOLE '(27 91 48 109)) )
(DEFUN INVERSE-VIDEO ()
(MAPC 'WRITE-CONSOLE '(27 91 48 59 55 109)) )
(DEFUN BLINK-WRITE-STRING (STRING)
(MAPC 'WRITE-CONSOLE '(27 91 48 59 53 109)) ;Turn blink mode ON
(WRITE-STRING STRING) ;Write string
(MAPC 'WRITE-CONSOLE '(27 91 48 109)) ) ;Turn blink mode OFF
))
(IF (EQ (CSMEMORY 855) 5) ;Z-100?
(PROGN
(SETQ *INIT-SCREEN* '(27 122 27 121 63)) ;Disable key expansion
(SETQ *RESET-SCREEN* '(27 122)) ;Power-up configuration
(SETQ *BORDER-CHARS* '(97 102 99 117 101 100 117 96 118 116 98))
(DEFUN WRITE-BORDER (CHAR NUM)
(MAPC 'WRITE-CONSOLE '(27 70)) ;Activate graphics mode
(WRITE-BYTE (NTH CHAR *BORDER-CHARS*) NUM)
(MAPC 'WRITE-CONSOLE '(27 71)) ) ;Deactivate graphics mode
(DEFUN NORMAL-VIDEO ()
(MAPC 'WRITE-CONSOLE '(27 113)) )
(DEFUN INVERSE-VIDEO ()
(MAPC 'WRITE-CONSOLE '(27 112)) )
(DEFUN BLINK-WRITE-STRING (STRING)
(MAPC 'WRITE-CONSOLE '(27 112)) ;Turn reverse video ON
(WRITE-STRING STRING) ;Write string
(MAPC 'WRITE-CONSOLE '(27 113)) ) ;Turn reverse video OFF
(DEFUN CURSOR-ON () ;Turn cursor ON
(MAPC 'WRITE-CONSOLE '(27 121 53)) )
(DEFUN CURSOR-OFF () ;Turn cursor OFF
((NOT *CURSOR-ON*)
(MAPC 'WRITE-CONSOLE '(27 120 53)) ) )
(SETQ *CURSOR-KEYS* '( ;Z-100 Key Generic Key
(165 . 5) ;Up arrow Ctrl-E
(184 . 5) ;Keypad 5 Ctrl-E
(166 . 24) ;Down arrow Ctrl-X
(178 . 24) ;Keypad 2 Ctrl-X
(168 . 19) ;<-- Ctrl-S
(180 . 19) ;Keypad 4 Ctrl-S
(167 . 4) ;--> Ctrl-D
(182 . 4) ;Keypad 6 Ctrl-D
(185 . 18) ;Keypad 9 Ctrl-R
(249 . 18) ;Shift-Keypad 9 Ctrl-R
(179 . 3) ;Keypad 3 Ctrl-C
(243 . 3) ;Shift-Keypad 3 Ctrl-C
(244 . 1) ;Shift-Keypad 4 Ctrl-A
(246 . 6) ;Shift-Keypad 6 Ctrl-F
(176 . 22) ;Keypad 0 Ctrl-V
(240 . 22) ;Shift-Keypad 0 Ctrl-V
(174 . 7) ;Keypad . Ctrl-G
(238 . 7) ;Shift-Keypad . Ctrl-G
(227 . 7) ;D CHR Ctrl-G
(163 . 22) ;I CHR Ctrl-V
(151 . -59) ;F1 F1
(215 . -84) ;Shift F1 Shift F1
(152 . -60) ;F2 F2
(216 . -85) ;Shift F2 Shift F2
(228 . 25) ;DELLINE Ctrl-Y
(164 . 14) ;INSLINE Ctrl-N
(232 . -31) ;Shift <-- Alt-S
(167 . -32) ;Shift --> Alt-D
(229 . -19) ;Shift Up arrow Alt-R
(230 . -46) ;Shift Down arrow Alt-C
(173 . -20) ;Keypad - Alt-T
(237 . -20) ;Shift-Keypad - Alt-T
(169 . -71) ;HOME Home
(183 . -71) ;Keypad 7 Home
(247 . -119) ;Shift-Keypad 7 Ctrl-Home
(233 . -79) ;Shift-HOME End
(177 . -79) ;Keypad 1 End
(241 . -117) ;Shift-Keypad 1 Ctrl-End
(141 . -120) ;ENTER Alt-!
(205 . -120) )) ;Shift-ENTER Alt-!
))