adds980.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.6 22725 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; ADDS980 Kludgorama --- BSG 2/12/79... from... ;;; HISI VIP7800 control package ;;; Ripped off from VIP7200ctl BSG 6/6/78 (!) ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (array* (notype (screen ?)))) (declare (special idel-lines-availablep idel-chars-availablep)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'adds980) (Rtyo 14) (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((= x 0) (Rtyo 13)(Rtyo (+ 100 y)) (setq X x Y y)) ((not (= y Y)) (DCTL-position-cursor 0 y) (DCTL-position-cursor x y)) ((> x X) (Rtyo 33)(Rtyo 5) (Rtyo (+ 60 (// (- x X) 10.))) (Rtyo (+ 60 (\ (- x X) 10.))) (setq X x)) ((< (- X x) 6) (do i (- X x)(1- i)(= i 0)(Rtyo 10)(setq X (1- X)))) (t (DCTL-position-cursor 0 Y) (DCTL-position-cursor x y)))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () ;Dont have eos, do all. (Rtyo 14)(setq X 0 Y 0)) ; Clear to end of line. (defun DCTL-kill-line1 () (do X1 X (1+ X1)(not (< X1 (cond ((screen Y)(cddr (screen Y))) (t 0)))) (Rtyo 40)(setq X (1+ X)))) (defun DCTL-kill-line () ((lambda (ox oy) (cond ((= Y (1- screenheight)) (DCTL-kill-line1)) ((and (screen Y)(< (- (cddr (screen Y)) X) 7)) (DCTL-kill-line1)) (t (Rtyo 15) (setq X 0 Y (1+ Y)))) (DCTL-position-cursor ox oy)) X Y)) (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rtyo 16))) (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rtyo 17)))  adm2.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.6 41598 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; ADM2 control package ;;; EAK 3/31/78 ;;; (declare (special dcaconses X Y screenheight tty-type)) (declare (special idel-lines-availablep idel-chars-availablep screenlinelen)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq dcaconses (list (ascii 33) '= nil nil)) (setq screenheight 24.) ; 20 lines for editing (setq screenlinelen 79.) (setq idel-lines-availablep t idel-chars-availablep t) (setq tty-type 'adm2) (Rtyo 33)(Rprinc "*") ; clear screen (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (prog (ycost ; cost of y and x relative xcost ; movement what ; which movement is best cost) ; cost of that movement (and (= x X)(= y Y) ; return right away if already (return nil)) ; at desired position (setq what 1 ; 1: "home and relative move" cost (+ 1 y x)) ; cost is V + H + 1 (and (> cost 4) ; direct cursor address better? (setq what 0 ; 0: "direct cursor address" cost 4)) ; cost is 4 characters (setq ycost (abs (- y Y))) (setq xcost (abs (- x X))) (and (< (+ ycost xcost) cost) (setq what 3 ; 3: "relative move" cost (+ ycost xcost))) (and (< (+ 1 ycost x) cost) (setq what 2)) ; 2: "CR and relative move" (cond ((= what 0) ; Direct Cursor Address (rplaca (cddr dcaconses) (+ 40 y)) (rplaca (cdddr dcaconses) (+ 40 x)) (Rprinc (implode dcaconses)) (setq X x Y y) (return nil)) ((= what 1) ; home and relative move? (Rtyo 36) ; home (setq X 0 Y 0)) ; keep track of cursor ; fall through to relative move ((= what 2) ; CR and relative move? (Rtyo 15) ; CR (setq X 0))) ; keep track of cursor ; fall through to relative move ; Relative Move (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 14))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 13)))) (setq X x Y y) (return nil))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "Y")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "T")) ; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (do i (stringlength str) (1- i) (= i 0) (Rtyo 33)(Rprinc "Q")) (Rprinc str) (setq X (+ X (stringlength str)))) ; Delete characters from current position in line. (defun DCTL-delete-chars (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "W"))) ; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "E"))) ; Delete n lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "R")))  adm3a.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.6 35703 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; ADM3 control package ;;; Created by Bob Frankston with Bernie's help ;;; 10 Mar 1979 ;;; BSG - Flushed DCTL-kill-line for tty-no-cleolp 2/14/80 ;;; (declare (special X Y screenheight tty-type)) (declare (special screenlinelen)) (declare (special idel-chars-availablep idel-lines-availablep tty-no-cleolp)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq screenheight 24.) ; 20 lines for editing (setq screenlinelen 79.) (setq tty-type 'adm3) (setq idel-lines-availablep nil idel-chars-availablep nil tty-no-cleolp t) (Rtyo 32) ; clear screen (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (prog (ycost ; cost of y and x relative xcost ; movement what ; which movement is best cost) ; cost of that movement (and (= x X)(= y Y) ; return right away if already (return nil)) ; at desired position (setq what 1 ; 1: "home and relative move" cost (+ 1 y x)) ; cost is V + H + 1 (and (> cost 4) ; direct cursor address better? (setq what 0 ; 0: "direct cursor address" cost 4)) ; cost is 4 characters (setq ycost (abs (- y Y))) (setq xcost (abs (- x X))) (and (< (+ ycost xcost) cost) (setq what 3 ; 3: "relative move" cost (+ ycost xcost))) (and (< (+ 1 ycost x) cost) (setq what 2)) ; 2: "CR and relative move" (cond ((= what 0) ; Direct Cursor Address (Rtyo 33) (Rprinc "=") (Rtyo (+ 40 y)) (Rtyo (+ 40 x)) (setq X x Y y) (return nil)) ((= what 1) ; home and relative move? (Rtyo 36) ; home (setq X 0 Y 0)) ; keep track of cursor ; fall through to relative move ((= what 2) ; CR and relative move? (Rtyo 15) ; CR (setq X 0))) ; keep track of cursor ; fall through to relative move ; Relative Move (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 14))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 13)))) (setq X x Y y) (return nil))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 32)(setq X 0 Y 0)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () ;Dont have eos, do all. (Rtyo 32)(setq X 0 Y 0))  ambassador.ctl.lisp 08/01/88 1001.1rew 08/01/88 0944.6 68643 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Bull Inc., 1988 * ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; AnnArbor Ambassador Controller ;;; HISTORY COMMENTS: ;;; 1) change(88-02-02,Schroth), approve(), audit(), install(): ;;; Pre-hcom journal. ;;; AnnArbor Ambassador pkg --- BSG 1/26/81 ;;; Tavares' Redisplay hacking features of 1/6/81 added, too. ;;; 2) change(88-02-02,Schroth), approve(88-02-29,MCR7852), ;;; audit(88-06-08,RBarstad), install(88-08-01,MR12.2-1071): ;;; Updated to make set-screen-size compatible with split screen. ;;; END HISTORY COMMENTS (%include emacs-rdis-dcls) (declare (special X Y screenheight screenlinelen ospeed DCTL-csistring)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep)) (declare (special given-tty-type DCTL-dcl-screen-height)) (declare (special modelwindow)) (declare (*expr DCTL-standard-set-screen-size Rprinc Rtyo reset-minibuffer-size wman-init)) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t screenlinelen 79. tty-type 'ambassador DCTL-prologue-availablep t DCTL-epilogue-availablep t X -777 Y -777) (setq DCTL-dcl-screen-height (or (cdr (assq given-tty-type '((ambassador . 30.) (ambassador_24l . 24.) (ambassador_30l . 30.) (ambassador_48l . 48.) (ambassador_60l . 60.)))) 30.)) (setq screenheight DCTL-dcl-screen-height) (setq DCTL-csistring (catenate (ascii 33) "[")) (DCTL-prologue) (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) (defun DCTL-prologue () (DCTL-csi1 49. "Q") ;Make ICH/DCH win (DCTL-csiprinc ">30l") ;RM ZDBM, make ^H win (DCTL-set-hw-screen-size screenheight)) (defun DCTL-epilogue () (DCTL-set-hw-screen-size DCTL-dcl-screen-height)) ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X) (= y Y)) nil) ;gudenov ((and (= x 0) (= y 0)) (DCTL-csiprinc "H") (setq X 0 Y 0)) ((or (< X 0)(< Y 0)) (DCTL-position-cursor 0 0) (DCTL-position-cursor x y)) ((= y Y) ;get away with "HPA"! (let ((d (- x X))) (cond ((= x 0)(Rtyo 15)) ;CR ((and (> d 0)(< d 10.)) ;HPR will do (DCTL-csi1 d "a")) ;HPR ((and (< d 0)(< (- d) 10.)) (setq d (- d)) (cond ((< d 5) (do i X (1- i)(= i x)(Rtyo 10))) ;^H (t (DCTL-csi1 d "D")))) (t (DCTL-csi1 (1+ x) "`")))) ;HPA (setq X x)) ((= x X) ;get away with "VPA"! (let ((d (- y Y))) (cond ((and (> d 0)(< d 10.)) ;VPR will do (cond ((< d 5) (do i Y (1+ i)(= i y)(Rtyo 12))) ;LF (t (DCTL-csi1 d "e")))) ;VPR ((and (< d 0)(< (- d) 10.)) ;CUU (setq d (- d)) (cond ((= d 1)(Rtyo 33)(Rprinc "M")) (t (DCTL-csi1 d "A")))) (t (DCTL-csi1 (1+ y) "d")))) ;VPA (setq Y y)) ((= x 0) ;CNL/CPL (DCTL-csi1 (abs (- y Y)) (cond ((> y Y) "E") ;CNL (t "F"))) ;CPL (setq Y y X 0)) ((and (< (+ (abs (- X x)) (abs (- Y y))) 3)) (DCTL-position-cursor x Y) (DCTL-position-cursor x y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (DCTL-csi1 (1+ y) ";") (DCTL-outANSIdec (1+ x)) (Rprinc "H")))) ;;; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (DCTL-csi1 0 "J")) ;;; Clear to end of line. (defun DCTL-kill-line () (DCTL-csi1 0 "K")) ;;; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (DCTL-csi1 (stringlength str) "@") (Rprinc str) (setq X (+ X (stringlength str)))) ;;; Delete characters from current position in line. (defun DCTL-delete-chars (n) (DCTL-csi1 n "P")) ;;; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (DCTL-csi1 n "L") (setq X 0)) ;;; Delete n lines at current position. (defun DCTL-delete-lines (n) (DCTL-csi1 n "M") (setq X 0)) ;;; Encoding cruft 1/26/81 (defun DCTL-csi1 (n stuff) (Rprinc DCTL-csistring) (DCTL-outANSIdec n) (Rprinc stuff)) (defun DCTL-outANSIdec (n) (cond ((or (= n 0)(= n 1))) (t (DCTL-outANSIdec-recurse n)))) (defun DCTL-outANSIdec-recurse (n) (cond ((> n 9)(DCTL-outANSIdec-recurse (// n 10.)))) (Rtyo (+ (CtoI "0") (\ n 10.)))) (defun DCTL-csiprinc (stuff) (Rprinc DCTL-csistring) (Rprinc stuff)) ;;; Send pad characters to wait specified number of milliseconds (defun DCTL-pad (n) (do i (1+ (// (* n ospeed) 1000.)) (1- i) (= i 0) (Rtyo 0))) ;;;; Tavares' hack ;;; the following hack enables the terminal to change its ACTUAL hardware ;;; screen size in response to the set-screen-size command. ;;; (Should work in supdup or emacs, nobody will call set-screen-size, ;;; fixed not to use decimal-rep -BSG 1/26/81) ;;; first, copy the REAL set-screen-size somewhere safe. (putprop 'DCTL-standard-set-screen-size (get 'set-screen-size 'subr) 'subr) (defun set-screen-size (screen-size) ;;; find the proper hardware screen size (setq screenheight (cond ((> screen-size 48.) 60.) ((> screen-size 40.) 48.) ((> screen-size 36.) 40.) ((> screen-size 30.) 36.) ((> screen-size 28.) 30.) ((> screen-size 26.) 28.) ((> screen-size 24.) 26.) ((> screen-size 20.) 24.) ((> screen-size 18.) 20.) (t 18.))) (DCTL-set-hw-screen-size screenheight) ;;; wipe out the dregs of the obsolete mode line and minibuffer, etc. (DCTL-position-cursor 0 (startline modelwindow)) (DCTL-clear-rest-of-screen) ;;; if the new screenheight is higher than ever, grow emacs' arrays. (cond ((> screenheight (cadr (arraydims screen))) ;; The following 'strange' *rearray is used as we must keep both ;; an array pointer and a named array reference up-to-date. (setq screen (*rearray 'screen t screenheight)) (setq eline-conts (*rearray 'eline-conts t screenheight)) (setq newscreen (*rearray 'newscreen t screenheight)))) ;;; perform the standard emacs action on set-screen-size (DCTL-standard-set-screen-size screen-size) ;;; make emacs recompute where to put the mode line, etc. (wman-init) (reset-minibuffer-size) ;;; force terminal to return screen to top of page (setq X -777 Y -777) ;randomize, force output (DCTL-position-cursor 0 0))) (defun DCTL-set-hw-screen-size (size) (DCTL-csiprinc "60;;;") (DCTL-outANSIdec size) (Rprinc "p") (setq X 0 Y 0)) ; hw also homes cursor  cdc713.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.6 17838 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; CDC713 control package ;;; JJL, with help from BSG 08/12/79 from VISTAR ;;; (declare (special X Y screenheight screenlinelen)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (eval (read)))(setsyntax '/^ 'macro 'hatmac) (declare (eval (read)))(defun hatmac ()(- (tyi) 100)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 16. screenlinelen 79.) (setq tty-type 'cdc713) (setq X 0 Y 0) (Rtyo ^Y)(Rtyo ^X)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y))) ((and (= x 0)(= y 0))(Rtyo ^Y)) ((and (= x 0)(= y Y))(Rtyo ^M)) (t (cond ((and (< x X)(> (- X x) x)) (cond ((and (< y Y)(> (- Y y) y)) (DCTL-position-cursor 0 0)) (t (DCTL-position-cursor 0 Y))))) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo ^U))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo ^H)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo ^J))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo ^Z)))))) (setq X x Y y)) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo ^X)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo ^V))  concept100.ctl.lisp 08/20/86 2312.9rew 08/20/86 2256.5 46278 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; Concept 100 control package ;;; DLW 3/12/79 ;;; HISTORY COMMENTS: ;;; 1) change(86-04-23,Margolin), approve(86-04-23,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added *expr declarations so that it would compile without warnings. ;;; END HISTORY COMMENTS ;;; (%include e-macros) (eval-when (compile) (setq ibase (+ 8 2))) (declare (special X Y screenheight screenlinelen ospeed tty-type idel-lines-availablep idel-chars-availablep overstrike-availablep region-scroll-availablep c100-magic-constant ; Fudge factor for Concept 100 padding vmax )) (declare (*expr Rprinc Rtyo)) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq screenheight 24 screenlinelen 79) (setq idel-lines-availablep t idel-chars-availablep nil) (setq region-scroll-availablep t) (setq tty-type 'c100) (setq overstrike-availablep t) ; Underscore! (setq c100-magic-constant (//$ 1.0 (-$ 1.0 (+$ .45 (*$ .3 (//$ (float ospeed) 960.0)))) 1000.0)) (Rtyo 27) (Rprinc "U") ; Set programmer mode. (Rtyo 27) (Rprinc "f") ; Set text mode. (Rtyo 27) (Rprinc "7") ; Set character mode. (Rtyo 27) (Rprinc "5") ; Set upper/lower case mode. (Rtyo 27) (Rprinc "8") ; Set full duplex. (Rtyo 27) (Rprinc "l") ; Reset auto-linefeed. (Rtyo 27) (Rprinc "N") ; Send set attribute word command. (Rtyo 72) ; Word is all 0 except protect = 1 ; (no protection) (Rtyo 27) (Rprinc "o") ; Change EOM to null. (Rtyo 38) (Rtyo 0) ; ... ; (Rtyo 27) (Rprinc "$") ; Reset all function keys. ;; Here program the function keys, if we ever want to use them. (DCTL-define-full-width-window 0 23) (DCTL-clear-screen) ; Clear and home. ;; Here we could set the tab stops but there is probably no reason. ) ;;; Move terminal's cursor to desired position. ;;; This first implementation is really cheapo and only uses ;;; absolute cursor positioning. (defun DCTL-position-cursor (x y) (cond ((and (= x X) (= y Y)) nil) ((and (= x 0) (= y 0)) ;; Home up. (Rtyo 27) (Rprinc "?")) ((= (+ (abs (- x X)) (abs (- y Y))) 1) ;; We are only one away, use relative positioning. (cond ((= x X) (cond ((< y Y) (Rtyo 27) (Rprinc ";")) (t (Rtyo 27) (Rprinc "<")))) (t (cond ((< x X) (Rtyo 27) (Rprinc ">")) (t (Rtyo 27) (Rprinc "=")))))) (t ;; Use absolute positioning. (Rtyo 27) (Rprinc "a") (Rtyo (+ 32 y)) (Rtyo (+ 32 x)))) (setq X x Y y) nil) ;;; Output a string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ;;; Home up and clear screen. (defun DCTL-clear-screen () (Rtyo 12) (DCTL-c100-pad 12.0) (setq Y 0 X 0)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (if (and (= Y 0) (= X 0)) (DCTL-clear-screen) else (Rtyo 27) (Rtyo 5) (DCTL-c100-pad (*$ 4.0 (float (- 24 Y)))))) ;;; Clear to end of line. (defun DCTL-kill-line () (Rtyo 27) (Rtyo 21) (DCTL-c100-pad 4.0)) ;;; Insert lines. (defun DCTL-insert-lines (n) (do-times n (Rtyo 27) (Rtyo 18) (DCTL-c100-pad (*$ .75 (float (- vmax X)))))) ;;; Delete lines. (defun DCTL-delete-lines (n) (do-times n (Rtyo 27) (Rtyo 2) (DCTL-c100-pad (*$ .75 (float (- vmax X)))))) (defun DCTL-define-full-width-window (top bottom) (Rtyo 27) (Rprinc "v") (Rtyo (+ top 32)) (Rtyo 32) (Rtyo (+ (- bottom top) 32 1)) (Rtyo (+ 80 32)) (setq Y top X 0 vmax bottom)) ;;; Move text in scroll region up n lines (inserts whitespace at bottom) (defun DCTL-scroll-up-region (nlines bottom) (DCTL-define-full-width-window Y bottom) (DCTL-delete-lines nlines) (DCTL-define-full-width-window 0 23)) ;;; Move text in scroll region down n lines (inserts whitespace at top) (defun DCTL-scroll-down-region (nlines bottom) (DCTL-define-full-width-window Y bottom) (DCTL-insert-lines nlines) (DCTL-define-full-width-window 0 23)) ;;; This takes a number of milliseconds, adjusts it by the ;;; magic constant, and sends the right number of pad characters. (defun DCTL-c100-pad (a) (do-times (fix (*$ a c100-magic-constant (float ospeed))) (Rtyo 127)))  delta4000.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.6 38007 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; Delta Data 4000 control package ;;; BSG 3/78 ;;; Modified by EAK 3/18/78 ;;; Consing removed in recognition of output buffering, BSG 8/31/78 (declare (special xconses yconses DCTLV-escf X Y screenheight ospeed screenlinelen tty-eolch-lossp)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) ;;; ;;; Whoever invented the **** eol frobs that caused me to have to ;;; propagate tty-eolch-lossp throughout n levels of hair, ;;; him, his fingers should be cut off. ; Initialize terminal and terminal control package. (defun DCTL-init () ; (setq idel-lines-availablep (= ospeed 1200.)) ; (setq idel-chars-availablep (< ospeed 1200.)) (setq idel-lines-availablep t idel-chars-availablep nil) ; This seems to be the most popular menu of poisons. (setq tty-eolch-lossp idel-lines-availablep) (setq DCTLV-escf (catenate (ascii 33) 'F)) (setq screenheight 25. screenlinelen 79.) (setq tty-type 'dd4000) (Rtyo 33) (Rprinc "E") (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C")(DCTL-pad 2500.))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 33)(Rprinc "D")(DCTL-pad 2500.)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "B")(DCTL-pad 2500.))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")(DCTL-pad 2500.)))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (DCTL-pad 3000.) (Rprinc DCTLV-escf) (Rtyo (+ 60 (// x 100.)))(setq x (\ x 100.)) (Rtyo (+ 60 (// x 10.)))(setq x (\ x 10.)) (Rtyo (+ 60 x)) (Rtyo (+ 60 (// y 100.)))(setq y (\ y 100.)) (Rtyo (+ 60 (// y 10.)))(setq y (\ y 10.)) (Rtyo (+ 60 y)) (DCTL-pad 5000.) ))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (DCTL-pad 9000.) (Rtyo 33)(Rprinc "J")(DCTL-pad 15000.)) ; Clear to end of line. (defun DCTL-kill-line () (DCTL-pad 10000.) (Rtyo 33)(Rprinc "K") (DCTL-pad 7500.)) ; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (Rtyo 33)(Rprinc "Q") (Rprinc str) (Rtyo 33)(Rprinc "R") (setq X (+ X (stringlength str)))) ; Delete characters from current position in line. (defun DCTL-delete-chars (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "P")(DCTL-pad 2500.))) ; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "L")(DCTL-pad 2500.))) ; Delete n lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "M")(DCTL-pad 100000.))) ; Send pad characters to wait specified no. of microseconds. (defun DCTL-pad (n) (do i (// (* n ospeed) 1000000.) (1- i) (= i 0) (Rtyo 0))) ; Random underscore to turn off losing DD features at high speeds. (defun idel-off () (setq idel-lines-availablep nil idel-chars-availablep nil))  dg132b.ctl.lisp 08/20/86 2312.9rew 08/20/86 2256.5 40599 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; DatagraphiX 132B emacs control package ;; ;; created 22 February 1979 by Lee A. Newcomb, HIS, FSO ;; ;; modified VIP 7800 controller. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; HISTORY COMMENTS: ;;; 1) change(86-04-23,Margolin), approve(86-04-23,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added *expr declarations so that it would compile without warnings. ;;; END HISTORY COMMENTS (%include e-macros) (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (special given-tty-type)) (declare (array* (notype (dg132b-posit ?)))) (declare (*expr Rprinc Rtyo)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq screenlinelen 131.) (setq screenheight (cond ((eq given-tty-type 'dg132b) 30.) ;30 lines for the screen ((eq given-tty-type 'dg132b120) 120.) ; user has the full terminal memory option ((eq given-tty-type 'dg132b60) 60.))) ; user has the default terminal memory (setq tty-type 'dg132b) (Rtyo 33)(Rprinc "H") ;clear/home cursor (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ;cursor already at ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "T") (setq X 0 Y 0)) ;go home ((and (< (+ (cond ((< x X) (- X x)) (t (* 2 (- x X)))) (cond ((< Y y) (- y Y)) (t (* 2 (- Y y))))) 8)) (cond ((< X x) (do ex X (1+ ex)(= ex x) (Rtyo 33) (Rprinc "L"))) ((< x X) (do ex x (1+ ex)(= ex X) (Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y) (Rtyo 12))) ((< y Y) (do wy y (1+ wy) (= wy Y)(Rtyo 33)(Rprinc "K")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "8")(Rprinc (dg132b-posit Y))(Rprinc (dg132b-posit X)) ))) ; Output string. (defun DCTL-display-char-string (string) (Rprinc string) (setq X (+ X (stringlength string)))) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "I")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "O")) (defun DCTL-insert-lines (n) (do i 1 (1+ i) (> i n) (Rtyo 33)(Rprinc "3"))) (defun DCTL-delete-lines (n) (do i 1 (1+ i) (> i n) (Rtyo 33)(Rprinc "4"))) (defun DCTL-insert-char-string (str) (Rtyo 33)(Rprinc "0") (Rprinc str) (Rtyo 33) (Rprinc "5") (setq X (+ X (stringlength str)))) (defun DCTL-delete-chars (n) (do i 0 (1+ i)(= i n) (Rtyo 33)(Rprinc "6"))) (array dg132b-posit t 132.) (fillarray 'dg132b-posit '("001" "002" "003" "004" "005" "006" "007" "008" "009" "010" "011" "012" "013" "014" "015" "016" "017" "018" "019" "020" "021" "022" "023" "024" "025" "026" "027" "028" "029" "030" "031" "032" "033" "034" "035" "036" "037" "038" "039" "040" "041" "042" "043" "044" "045" "046" "047" "048" "049" "050" "051" "052" "053" "054" "055" "056" "057" "058" "059" "060" "061" "062" "063" "064" "065" "066" "067" "068" "069" "070" "071" "072" "073" "074" "075" "076" "077" "078" "079" "080" "081" "082" "083" "084" "085" "086" "087" "088" "089" "090" "091" "092" "093" "094" "095" "096" "097" "098" "099" "100" "101" "102" "103" "104" "105" "106" "107" "108" "109" "110" "111" "112" "113" "114" "115" "116" "117" "118" "119" "120" "121" "122" "123" "124" "125" "126" "127" "128" "129" "130" "131" "132"))  dku7102.ctl.lisp 08/20/86 2312.9rew 08/20/86 2306.2 38430 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1983 * ;;; * * ;;; *********************************************************** ;;; -*-LISP-*- ;;; ;;; Bull DKU7102 CTL package ;;; 6 May 83 by G.Sauvagnat for DKU7102 (SDP mode). ;;; ;;; Include (%include e-macros) ;;; Declarations (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep)) (declare (special DCTL-insert-mode-on)) (declare (*expr Rprinc Rtyo)) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 ((lambda (have-output) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi))))) nil)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'dku7102) (DCTL-prologue) (Rtyo 33)(Rprinc "[2J") ; Effacement de l'ecran (Rtyo 33)(Rprinc "[H") ; Positionnement C1 L1 (setq X 0 Y 0)) ;;; Prologue code (defun DCTL-prologue () (Rtyo 33) (Rprinc "[?=h") ; Passage en mode SDP (DCTL-set-insert-mode nil) (Rtyo 33) (Rprinc "[=l") ; Passage en mode PAGE ;;; Epilogue code (defun DCTL-epilogue () (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "c")) ; Reset Initial State (RIS) ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) ;(redf y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "[H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "[C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 33)(Rprinc "[D")))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "[B"))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "[A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "[")(DCTL-outdec (1+ y))(Rprinc ";")(DCTL-outdec (1+ x))(Rprinc "f") ))) ;;; Output string. (defun DCTL-display-char-string (string) ((lambda (strx) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (DCTL-set-insert-mode nil) ; (cond ((< 19. Y) (Rtyo 33)(Rprinc "[2;7m"))) (Rprinc string) (setq X (+ X strx))))) (stringlength string))) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "[0J")) ;;; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "[0K")) ;;; Insert lines (defun DCTL-insert-lines (n) (Rtyo 33)(Rprinc "[")(DCTL-outdec n)(Rprinc "L"))) ;;; Delete lines (defun DCTL-delete-lines (n) (Rtyo 33)(Rprinc "[")(DCTL-outdec n)(Rprinc "M"))) ;;; Insert character string (defun DCTL-insert-char-string (str) (DCTL-set-insert-mode t) (Rprinc str) (setq X (+ X (stringlength str)))) ;;; Delete characters (defun DCTL-delete-chars (n) (Rtyo 33)(Rprinc "[")(DCTL-outdec n)(Rprinc "P")) ;;; Mode insertion (defun DCTL-set-insert-mode (bit) (if bit ; on le veut on (if DCTL-insert-mode-on ; ne rien faire else (setq DCTL-insert-mode-on t) (Rtyo 33) (Rprinc "[4h")) else (if (not DCTL-insert-mode-on) else (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "[4l")))) ;;; Inverse video? ;(defun redf (y) ; (cond ((< 19. Y) nil) ; ((and (> 20. Y)(> 20. y)) nil) ; (t (Rtyo 33)(Rprinc "[0m"))))  dm1521.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 20556 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; DATAMEDIA 1521 control package ;;; Adapted from vip7200ctl by Richard Q. Kahler 7/10/79 ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'dm1521) (Rtyo 14) ;clear screen (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ;already there ((and (= x 0)(= y 0)) (Rtyo 31) ;cursor home (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 34))) ;cursor right ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) ;cursor left (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ;cursor down ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 37)))) ;cursor up (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 36)(Rtyo (+ 40 x))(Rtyo y) ))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 13)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 35))  dm2500.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 26415 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; Data Media 2500 control package ;;; EAK 3/27/78 ;;; (declare (special dcaconses X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq dcaconses (list (ascii 14) nil nil)) (setq screenheight 24. ; 20 lines for editing screenlinelen 79.) (setq tty-type 'dm2500) (DCTL-clear-screen)) ; clear whole screen ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 2) (setq X 0 Y 0)) ;;; Direct Cursor Addressing is best. (t (rplaca (cdr dcaconses) (boole 6 x 140)) (rplaca (cddr dcaconses) (boole 6 y 140)) (Rprinc (implode dcaconses)) (setq X x Y y)))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear whole screen. (defun DCTL-clear-screen () (Rtyo 36) (setq X 0 Y 0)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () ((lambda (x y) (do i Y (1+ i) (= i (1- screenheight)) (Rprinc (catenate (ascii 27) (ascii 15) (ascii 12))) (setq X 0 Y (1+ Y))) (Rtyo 27) (DCTL-position-cursor x y)) X Y)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 27)) ; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (Rtyo 20) (do i (stringlength str) (1- i) (not (> i 0)) (Rtyo 34)) (Rtyo 30) (Rprinc str) (setq X (+ X (stringlength str)))) ; Delete characters from current position in line. (defun DCTL-delete-chars (n) (Rtyo 20) (do i 1 (1+ i)(> i n) (Rtyo 10)) (Rtyo 30)) ; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (Rtyo 20) (do i 1 (1+ i)(> i n) (Rtyo 12)) (Rtyo 30)) ; Delete n lines at current position. (defun DCTL-delete-lines (n) (Rtyo 20) (do i 1 (1+ i)(> i n) (Rtyo 32)) (Rtyo 30))  dm3000.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 27693 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; DATAMEDIA 3000 control package ;;; WOS, 11/08/78 from TELERAY1061 package ;;; (declare (special X Y screenheight screenlinelen ospeed)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t screenheight 24. screenlinelen 79. tty-type 'dm3000 X -777 Y -777) (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X) (= y Y)) nil) ((and (= x 0) (= y 0)) (Rtyo 33) (Rprinc "H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x)) (abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex) (= ex x) (Rtyo 33) (Rprinc "C"))) ((< x X) (do ex x (1+ ex) (= ex X) (Rtyo 010)))) (cond ((< Y y) (do wy Y (1+ wy) (= wy y) (Rtyo 33) (Rprinc "B"))) ((< y Y) (do wy y (1+ wy) (= wy Y) (Rtyo 33) (Rprinc "A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33) (Rprinc "Y") (Rtyo (+ 40 y)) (Rtyo (+ 40 x))))) ;;; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33) (Rprinc "J")) ;;; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33) (Rprinc "K")) ;;; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (Rtyo 33) (Rprinc "P") (Rprinc str) (Rtyo 33) (Rprinc "Q") (setq X (+ X (stringlength str)))) ;;; Delete characters from current position in line. (defun DCTL-delete-chars (n) (Rtyo 33) (Rprinc "P") (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "D")) (Rtyo 33) (Rprinc "Q")) ;;; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (Rtyo 33) (Rprinc "P") (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "B") (DCTL-pad 130.)) (Rtyo 33) (Rprinc "Q") (setq X 0)) ;;; Delete n lines at current position. (defun DCTL-delete-lines (n) (Rtyo 33) (Rprinc "P") (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "A") (DCTL-pad 130.)) (Rtyo 33) (Rprinc "Q") (setq X 0)) ;;; Send pad characters to wait specified number of milliseconds (defun DCTL-pad (n) (do i (1+ (// (* n ospeed) 1000.)) (1- i) (= i 0) (Rtyo 177)))  fox1100.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 19998 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; FOX-1100 control package ;;; GMP on 08/17/78 ;;; (declare (special X Y screenheight screenlinelen)) (declare (special tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil screenheight 24. screenlinelen 79. tty-type 'fox) (setq X -1 Y -1) (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X) (= y Y)) nil) ((and (= x 0) (= y 0)) (Rtyo 33) (Rprinc "H") (setq X 0 Y 0)) (t (or (= x X) (cond ((= x 0) (Rtyo 15)) ((< (abs (- x X)) 2) (cond ((< X x) (do ex X (1+ ex) (= ex x) (Rtyo 33) (Rprinc "C"))) ((< x X) (do ex x (1+ ex) (= ex X) (Rtyo 010))))) (t (Rtyo 33) (Rprinc "Y") (Rtyo (+ 40 x))))) (or (= y Y) (cond ((= y (1+ Y)) (Rtyo 12)) ((< (abs (- y Y)) 2) (cond ((< Y y) (do wy Y (1+ wy) (= wy y) (Rtyo 33) (Rprinc "B"))) ((< y Y) (do wy y (1+ wy) (= wy Y) (Rtyo 33) (Rprinc "A"))))) (t (Rtyo 33) (Rprinc "X") (Rtyo (+ 40 y))))) (setq X x Y y)))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33) (Rprinc "J")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33) (Rprinc "I"))  glasstty.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 17874 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Glass tty display control ;;; From printing tty, BSG 6/29/78 ;;; Redone for new redisplay 7/7/78 ;;; For tty-no-cleolp, bsg 2/14/80 (declare (special X Y screenheight idel-lines-availablep idel-chars-availablep screenlinelen tty-type tty-no-upmotionp tty-no-cleolp)) (declare (array* (notype (newscreen ?)))) (defun DCTL-init () (setq X -777 Y -777) (setq tty-type 'teleray) (setq screenheight 24. screenlinelen 79.) (setq idel-chars-availablep nil idel-lines-availablep nil tty-no-upmotionp t tty-no-cleolp t)) (defun DCTL-position-cursor (x y) (prog () (and (= x X)(= y Y)(return nil)) (and (< X 0)(DCTL-crlf)) (and (= y Y) (progn (cond ((and (= x 0)(> X 4))(DCTL-cret)) ((< X x)(DCTL-display-char-string (substr (or (cadr (newscreen Y)) " ") (1+ X) (- x X)))) ((< (- X x) x) (do xx X (1- xx)(= xx x)(Rtyo 10))) (t (DCTL-cret) (DCTL-position-cursor x Y))) (setq X x) ;y is right by definition (return nil))) ;; Definitely going to a new line at this point (DCTL-nextline) (setq Y y) (DCTL-position-cursor x y))) (defun DCTL-assert-scpos (x y) (and x (setq X x)) (and y (setq Y y))) (defun DCTL-clear-rest-of-screen ()) (defun DCTL-nextline ()(Rtyo 12)) (defun DCTL-display-char-string (s) (Rprinc s) (setq X (+ X (stringlength s)))) (defun DCTL-cret () (Rtyo 15)(setq X 0)) (defun DCTL-crlf () (Rtyo 15)(Rtyo 12)(setq X 0))  hazeltine1510.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 24543 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; Hazeltine 1510 control package ;;; Ripped off from VIP7800ctl by CDT, 01/80 ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep nil) (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'haz1510) (Rtyo 33)(Rtyo 34) (setq X 0 Y 0) (DCTL-prologue)) ;;; Prologue code (defun DCTL-prologue () (Rtyo 33) (Rtyo 34)) ;;; Epilogue code (defun DCTL-epilogue () (Rtyo 33) (Rtyo 34)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rtyo 22) (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 3)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 20))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rtyo 13))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rtyo 14)))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rtyo 21)(Rtyo x)(Rtyo y) ))) ;;; Output string. (defun DCTL-display-char-string (string) ((lambda (strx) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (Rprinc string) (setq X (+ X strx))))) (stringlength string))) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rtyo 30)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rtyo 17)) (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rtyo 32))) (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rtyo 23)))  heath19.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 33723 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; H19 control package ;;; BSG 3/21/78 from DD4000ctl ;;; CAH 7/18/79 from vt52ctl ;;; WMY 8/27/80 to add insert-mode stuff ;;; AEB 9/17/80 Added delays to delete/insert lines and delete chars ;;; (declare (special X Y ospeed screenheight screenlinelen)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-insert-mode-on)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'h19) (Rtyo 33)(Rprinc "H")(Rtyo 33)(Rprinc "J") (setq X 0 Y 0) (DCTL-prologue)) ;;; Prologue (defun DCTL-prologue () (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "O")) ; turn off insert-mode ;;; Epilogue (defun DCTL-epilogue () (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "O")) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 010)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "B"))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "Y")(Rtyo (+ 40 y))(Rtyo (+ 40 x)) ))) ; Output string. (defun DCTL-display-char-string (string) (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "O"))) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "J")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K")) ; Insert character string at current position. (defun DCTL-insert-char-string (str) (cond ((not DCTL-insert-mode-on) (setq DCTL-insert-mode-on t) (Rtyo 33)(Rprinc "@"))) (Rprinc str) (let ((len (stringlength str))) (DCTL-pad (* len 1050.)) (setq X (+ X len)))) ;;; Delete characters from current position in line. (defun DCTL-delete-chars (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "N")) (DCTL-pad (* n 2900.))) ;;; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "L") (DCTL-pad 24000.)) (setq X 0)) ;;; Delete n lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "M") (DCTL-pad 24000.)) (setq X 0)) ; Send pad characters (defun DCTL-pad (n) (do i (// (* n ospeed) 1000000.) (1- i) (= i 0) (Rtyo 0)))  hp2645.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 39924 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; HP2645 control package ;;; EAK 3/18/78 ;;; (declare (special xconses yconses escfxconsesyconses X Y screenheight ospeed tty-type)) (declare (special idel-lines-availablep idel-chars-availablep screenlinelen)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq xconses (list nil nil)) (setq yconses (list nil nil)) (setq escfxconsesyconses (nconc (list (ascii 33) '& 'a) xconses (list 'c) yconses (list 'R))) (setq screenheight 24.) ; 20 lines for editing (setq screenlinelen 79.) (setq idel-lines-availablep t idel-chars-availablep t) (setq tty-type 'hp2645) (Rtyo 33) (Rprinc "H") ; clear screen: home, (Rtyo 33) (Rprinc "J") ; and erase to end (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (prog (ycost ; cost of y and x relative xcost ; movement what ; which movement is best cost) ; cost of that movement (and (= x X)(= y Y) ; return right away if already (return nil)) ; at desired position (setq what 1 ; 1: "home and relative move" cost (+ 2 y x x)) ; cost is V + 2H + 2 (and (> cost 9) ; direct cursor address better? (setq what 0 ; 0: "direct cursor address" cost 9)) ; cost is 9 characters (setq ycost (- y Y)) (and (< ycost 0) (setq ycost (* (- ycost) 2))) (setq xcost (- X x)) (and (< xcost 0) (setq xcost (* (- xcost) 2))) (and (< (+ ycost xcost) cost) (setq what 3 ; 3: "relative move" cost (+ ycost xcost))) (and (< (+ 1 ycost x x) cost) (setq what 2)) ; 2: "CR and relative move" (cond ((= what 0) ; Direct Cursor Address (rplaca xconses (+ 60 (// x 10.))) (rplaca (cdr xconses) (+ 60 (\ x 10.))) (rplaca yconses (+ 60 (// y 10.))) (rplaca (cdr yconses) (+ 60 (\ y 10.))) (Rprinc (implode escfxconsesyconses)) (setq X x Y y) (return nil)) ((= what 1) ; home and relative move? (Rtyo 33)(Rprinc "H") ; home (setq X 0 Y 0)) ; keep track of cursor ; fall through to relative move ((= what 2) ; CR and relative move? (Rtyo 15) ; CR (setq X 0))) ; keep track of cursor ; fall through to relative move ; Relative Move (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")))) (setq X x Y y) (return nil))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "J")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K")) ; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (Rtyo 33)(Rprinc "Q") (Rprinc str) (Rtyo 33)(Rprinc "R") (setq X (+ X (stringlength str)))) ; Delete characters from current position in line. (defun DCTL-delete-chars (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "P")(DCTL-pad 7000.))) ; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "L"))) ; Delete n lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "M"))) ; Send pad characters to wait specified no. of microseconds. (defun DCTL-pad (n) (do i (// (* n ospeed) 1000000.) (1- i) (= i 0) (Rtyo 0)))  ibm3101.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 30348 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; IBM 3101 control package ;;; Coded: 29 October 1979 by GMP ;;; (declare (special given-tty-type tty-type ospeed idel-lines-availablep idel-chars-availablep screenheight screenlinelen X Y)) ;;; Initialize terminal and terminal control package (defun DCTL-init () (setq screenheight 24. screenlinelen 79.) (cond ((eq given-tty-type 'ibm3101_2x) ;has insert/delete line/character (setq idel-lines-availablep t idel-chars-availablep t)) (t ;assume it doesn't have them (setq idel-lines-availablep nil idel-chars-availablep nil))) (setq tty-type 'ibm3101) (Rtyo 33) (Rprinc "H") (Rtyo 33) (Rprinc "J") ;home and clear screen (setq X 0 Y 0)) ;;; Position terminal's cursor to desired position (defun DCTL-position-cursor (x y) (cond ((and (= x X) (= y Y)) nil) ;already in correct position ((and (= x 0) (= y 0)) ;wants to home the cursor (Rtyo 33) (Rprinc "H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x)) (abs (- Y y))) 4)) ;can use relative motion (cond ((< X x) (do ex X (1+ ex) (= ex x) (Rtyo 33) (Rprinc "C"))) ((< x X) (do ex x (1+ ex) (= ex X) (Rtyo 010)))) (cond ((< Y y) (do wy Y (1+ wy) (= wy y) (Rtyo 33) (Rprinc "B"))) ((< y Y) (do wy y (1+ wy) (= wy Y) (Rtyo 33) (Rprinc "A")))) (setq X x Y y)) (t (setq X x Y y) ;direct cursor addressing is the right thing (Rtyo 33) (Rprinc "Y") (Rtyo (+ 40 y)) (Rtyo (+ 40 x))))) ;;; Output the given string (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ;;; Clear to end of screen (defun DCTL-clear-rest-of-screen () (Rtyo 33) (Rprinc "J")) ;;; Clear to end of line (defun DCTL-kill-line () (Rtyo 33) (Rprinc "I")) ;;; Insert character string in line at current position (defun DCTL-insert-char-string (string) (do i 1 (1+ i) (> i (stringlength string)) (Rtyo 33) (Rprinc "P") (Rprinc (substr string i 1)) (DCTL-pad 100)) (setq X (+ X (stringlength string)))) ;;; Delete characters from the current position in the line (defun DCTL-delete-chars (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "Q") (DCTL-pad 100))) ;; Insert blank lines at the current position (defun DCTL-insert-lines (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "N") (DCTL-pad 100)) (setq X 0)) ;;; Delete lines at current position (defun DCTL-delete-lines (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "O") (DCTL-pad 100)) (setq X 0)) ;;; Pad for specified number of milliseconds (defun DCTL-pad (n) (do i (1+ (// (* n ospeed) 1000.)) (1- i) (= i 0) (Rtyo 177)))  infoton100.ctl.lisp 08/20/86 2312.9rew 08/20/86 2256.5 32463 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; I100 control package ;;; CWH 3/5/79 from VT52ctl ;;; BSG 3/21/78 from DD4000ctl ;;; ;;; HISTORY COMMENTS: ;;; 1) change(86-04-23,Margolin), approve(86-04-23,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added *expr declarations so that it would compile without warnings. ;;; END HISTORY COMMENTS (%include e-macros) (declare (special X Y screenheight screenlinelen ospeed)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (*expr Rprinc Rtyo)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'infoton100) (DCTL-home-cursor) (DCTL-clear-rest-of-screen) (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (DCTL-home-cursor) (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 010)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "B"))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "f")(Rtyo (+ 40 x))(Rtyo (+ 40 y)) ))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Home cursor to upper left corner. (defun DCTL-home-cursor () (Rtyo 33) (Rprinc "H")) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33) (Rprinc "J")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K")) ; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33) (Rprinc "L") (DCTL-pad 100000.))) ; Delete n lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33) (Rprinc "M") (DCTL-pad 100000.))) ; Send pad characters (defun DCTL-pad (n) (do i (// (* n ospeed) 1000000.) (1- i) (= i 0) (Rtyo 0))) ; Delete characters from current position in line. ; This won't work unless the terminal has the block mode option. ; Create a separate terminal type? ;(defun DCTL-delete-chars (n) ; (do i 1 (1+ i)(> i n) ; (Rtyo 33) (Rprinc "P"))) ; Insert character string in line at current position. ; This won't work unless terminal has block mode option. ;(defun DCTL-insert-char-string (str) ; (do i (stringlength str) (1- i) (= i 0) ; (Rtyo 33) (Rprinc "@")) ; (Rprinc str) ; (setq X (+ X (stringlength str))))  iq120.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 19269 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; Soroc IQ120 control package ;;; Ripped off from vt52ctl Paul Schauble 3/24/79 ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'iq120) (Rtyo 33) (Rprinc "*") (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 36) (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 14))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 13)))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33) (Rprinc "=")(Rtyo (+ 40 y))(Rtyo (+ 40 x)) ))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "Y")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "T"))  iriscope200.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 24984 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; Iriscope 200 control package ;;; Ripped off from vt52ctl BSG 3/9/78 ;;; Ripped off from VIP7200ctl by CAH 17 July 1980 ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 16. screenlinelen 80.) (setq tty-type 'iriscope200) (Rtyo 30) (Rtyo 31) (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and ; near home position? (< (DCTL-distance y 0 16.) (DCTL-distance Y y 16.)) (< (+ (DCTL-distance x 0 80.) (DCTL-distance y 0 16.)) (+ (DCTL-distance X x 80.) (DCTL-distance Y y 16.)))) (Rtyo 31) ; yes: go there first (setq X 0 Y 0))) (cond ((< (DCTL-distance x 0 80.) (DCTL-distance X x 80.)) (Rtyo 15) ; yes: go there (setq X 0))) (cond ((< X x) (cond ((< (- x X) 40.) (DCTL-rpt 25 (- x X))) (t (setq Y (1- Y)) (DCTL-rpt 10 (+ 80. (- X x)))))) (t (cond ((< (- X x) 40.) (DCTL-rpt 10 (- X x))) (t (setq Y (1+ Y)) (DCTL-rpt 25 (+ 80. (- x X))))))) (cond ((< Y y) (cond ((< (- y Y) 8.) (DCTL-rpt 12 (- y Y))) (t (DCTL-rpt 32 (+ 16. (- Y y)))))) (t (cond ((< (- Y y) 8.) (DCTL-rpt 32 (- Y y))) (t (DCTL-rpt 12 (+ 16. (- y Y))))))) (setq X x Y y)) ; find modular distance between two points (defun DCTL-distance (A B Mod) (cond ((< (abs (- A B)) (// Mod 2)) (abs (- A B))) ((< A B) (- (+ Mod A) B)) ((> A B) (- (+ Mod B) A)))) ; send a cursor positioning string (defun DCTL-rpt (Char Num) (do ex 1 (1+ ex) (> ex Num) (Rtyo Char))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string) (cond ((< X 80.) nil) (t (setq X (- X 80.)) (setq Y (1+ Y))))) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () ((lambda (x y) (Rtyo 30) (setq X 0 Y 0) (DCTL-position-cursor x y)) X Y)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 26))  ktm2.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 19962 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Synertek KTM2 control package ;;; ;;; JRD 9 Sept 79 from vt52ctl, debugged by BSG ;;; BSG 3/21/78 from DD4000ctl ;;; (declare (special X Y screenheight screenlinelen)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'ktm2) (Rtyo 33)(Rprinc "E")(Rtyo 177)(Rtyo 177) (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "H") (setq X 0 Y 0)) (t (let ((cost-of-rel (+ (abs (- x X))(abs (- y Y)))) (cost-of-left (+ 1 x (abs (- y Y)))) (cost-of-abs 4)) (cond ((and (< cost-of-rel cost-of-left) (< cost-of-rel cost-of-abs)) (cond ((> X x) (do i X (1- i) (= i x)(Rtyo 10))) ((> x X) (do i X (1+ i) (= i x)(Rtyo 11)))) (cond ((> Y y) (do i Y (1- i) (= i y)(Rtyo 13))) ((> y Y) (do i Y (1+ i) (= i y)(Rtyo 12))))) ((and (< cost-of-left cost-of-abs)(not (= X 0))) (Rtyo 15) (setq X 0) (DCTL-position-cursor x y)) (t (Rtyo 33)(Rprinc "=") (Rtyo (+ 40 y))(Rtyo (+ 40 x))))) (setq X x Y y)))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "J")(Rtyo 177)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K"))  mmind.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.7 36144 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; Micromind Ctl ;;; From DD4000 5/18/78 BSG ;;; Modified 3/23/79 JSL ;;; (declare (special X Y screenheight screenlinelen ospeed rdis-whitespace-optimize)) (declare (special idel-lines-availablep idel-chars-availablep tty-type overstrike-availablep)) (declare (defpl1 e_pl1_$get_mcs_tty_info "" (return bit (1))(return float bin)(return fixed bin) (return float bin)(return fixed bin)(return fixed bin)(return fixed bin))) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t overstrike-availablep t) (setq rdis-whitespace-optimize nil) (setq tty-type 'micromind) (setq screenlinelen (1- (caddr (cddddr (e_pl1_$get_mcs_tty_info)))) screenheight 34.) (setq X -777 Y -777) ; N.B. ^L does this so we should be able to handle it. (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ; we're there...do nothing ((and (= x 0)(= y Y))(Rtyo 15)) ; just go to beginning of current line ((and (= x 0)(= y 0))(Rtyo 33)(Rprinc "H")(DCTL-pad (* 25000. (min (abs Y) screenheight)))) ; go home. ((and (< (+ (max (min (- X x)(1+ (* 2 x)))(* 2 (- x X)))(max (- y Y)(* 2 (- Y y)))) (cond ((< X 95.) 4)(t 8)))) (and (< (1+ (* 2 x)) (- X x)) (setq X 0) (Rtyo 15)) ; yes. do carriage return if faster. (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C"))) ; move right ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) ; move left (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12)(DCTL-pad 25000.))) ; move down ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")(DCTL-pad 25000.))))) ; move up ((< x 95.)(Rtyo 33)(Rprinc "Y") ; use abs. cursor address. short form? (Rtyo (+ y 41)) (Rtyo (+ x 40)) (DCTL-pad (* 25000. (min (abs (- y Y)) screenheight)))) (t (Rtyo 33) (Rprinc "F") ; no. use long form. (Rtyo (+ 60 (// x 100.))) (Rtyo (+ 60 (\ (// x 10.) 10.))) (Rtyo (+ 60 (\ x 10.))) (Rtyo (+ 60 (// y 100.))) (Rtyo (+ 60 (\ (// y 10.) 10.))) (Rtyo (+ 60 (\ y 10.))) (DCTL-pad (* 25000. (min (abs (- y Y)) screenheight))))) (setq X x Y y)) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "J") (DCTL-pad (* 50000. (- screenheight Y)))) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K")) ; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (Rtyo 33)(Rprinc "Q") (Rprinc str) (Rtyo 33)(Rprinc "R") (setq X (+ X (stringlength str)))) ; Delete characters from current position in line. (defun DCTL-delete-chars (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "P"))) ; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "L")(DCTL-pad 50000.))) ; Delete n lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "M")(DCTL-pad 50000.))) ; Send pad characters to wait specified no. of microseconds. (defun DCTL-pad (n) (do i (// (* n ospeed) 1000000.) (1- i) (= i 0) (Rtyo 0)))  owl1200.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 31149 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1981 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; OWL 1200 control pachage ;;; Richard Lamson, 05/13/81 from TELERAY 1061 control package ;;; GMP, 08/14/78 from VT52 package ;;; (eval-when (compile eval) (setsyntax '/# 'macro 'sharp-macro) (defun sharp-macro () (let ((ch (tyi))) (or (= ch 57) ; #/ is the only # macro here (error "Unknown # character: " (ItoC ch) 'fail-act)) (tyi))) ; return character number ) (declare (special X Y screenheight screenlinelen ospeed %DCTL-escape-char)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t screenheight 24. screenlinelen 79. tty-type 'teleray1061 X -777 Y -777 %DCTL-escape-char 33) (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X) (= y Y)) nil) ((and (= x 0) (= y 0)) (Rtyo %DCTL-escape-char) (Rtyo #/H) (setq X 0 Y 0)) (t ; must actually set X and Y (cond ((= x (1- X)) (Rtyo 10)) ((= (1+ x) (1- X)) (Rtyo 10) (Rtyo 10)) ((= X (1- x)) (Rtyo %DCTL-escape-char) (Rtyo #/C)) (t (Rtyo %DCTL-escape-char) (Rtyo #/Y) (Rtyo y))) (cond ((= y (1- Y)) (Rtyo %DCTL-escape-char) (Rtyo #/A)) ((= Y (1- y)) (Rtyo %DCTL-escape-char) (Rtyo #/B)) (t (Rtyo %DCTL-escape-char) (Rtyo #/X) (Rtyo y))) (setq X x Y x)))) ;;; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo %DCTL-escape-char) (Rtyo #/J) (DCTL-pad 132.)) ;;; Clear to end of line. (defun DCTL-kill-line () (Rtyo %DCTL-escape-char) (Rtyo #/K) (DCTL-pad 6.)) ;;; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (let ((stringlength (stringlength str))) (cond ((= 0 stringlength)) (t (do i 1 (1+ i) (= i stringlength) (Rtyo %DCTL-escape-char) (Rtyo #/N) (Rprinc (substr str i 1))) (setq X (+ X stringlength)))))) ;;; Delete characters from current position in line. (defun DCTL-delete-chars (n) (do i 1 (1+ i) (> i n) (Rtyo %DCTL-escape-char) (Rtyo #/O))) ;;; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i) (> i n) (Rtyo %DCTL-escape-char) (Rtyo #/L)) (DCTL-pad (* 6. n)) (setq X 0)) ;;; Delete n lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i) (> i n) (Rtyo %DCTL-escape-char) (Rtyo #/M)) (DCTL-pad (* 6. n)) (setq X 0)) ;;; Send pad characters to wait specified number of milliseconds (defun DCTL-pad (n) (do i (1+ (// (* n ospeed) 1000.)) (1- i) (= i 0) (Rtyo 0)))  pe550.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 22419 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; pe550ctl - BSG 7/19/79 -- from ;;; FOX-1100 control package ;;; GMP on 08/17/78 ;;; (declare (special X Y screenheight screenlinelen ospeed)) (declare (special tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil screenheight 24. screenlinelen 79. tty-type 'pe550) (setq X -1 Y -1) (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X) (= y Y)) nil) ((and (= x 0) (= y 0)) (Rtyo 33) (Rprinc "H") (setq X 0 Y 0)) (t (or (= x X) (cond ((= x 0) (Rtyo 15)) ((< (abs (- x X)) 2) (cond ((< X x) (do ex X (1+ ex) (= ex x) (Rtyo 33) (Rprinc "C"))) ((< x X) (do ex x (1+ ex) (= ex X) (Rtyo 010))))) (t (Rtyo 33) (Rprinc "Y") (Rtyo (+ 40 x))))) (or (= y Y) (cond ((= y (1+ Y)) (Rtyo 12)) ((< (abs (- y Y)) 2) (cond ((< Y y) (do wy Y (1+ wy) (= wy y) (Rtyo 33) (Rprinc "B"))) ((< y Y) (do wy y (1+ wy) (= wy Y) (Rtyo 33) (Rprinc "A"))))) (t (Rtyo 33) (Rprinc "X") (Rtyo (+ 40 y))))) (setq X x Y y)))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () ;Really clear whole screen (Rtyo 33) (Rprinc "K")(DCTL-pad 20000.) (setq X 0 Y 0)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33) (Rprinc "I")(DCTL-pad 20000.)) ; Send pad characters to wait specified no. of microseconds. (defun DCTL-pad (n) (do i (// (* n ospeed) 1000000.) (1- i) (= i 0) (Rtyo 0)))  printing.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 37035 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; Printing tty display control ;;; Redone for new redisplay 7/7/78 ;;; Large redo 8/9/78 for tabs, delays, and no screen knowledge. (declare (special X Y screenheight idel-lines-availablep idel-chars-availablep screenlinelen tty-type tty-no-upmotionp overstrike-availablep)) (declare (special DCTLV-vertnl-pad DCTLV-horznl-pad DCTLV-consttab-pad DCTLV-vartab-pad DCTLV-tabs-availablep DCTLV-backspace-pad DCTLV-one-time-bspad)) (declare (defpl1 e_pl1_$get_mcs_tty_info "" (return bit (1))(return float bin)(return fixed bin) (return float bin)(return fixed bin)(return fixed bin)(return fixed bin))) (defun DCTL-init () (setq X -777 Y -777) (setq tty-type 'printing) (setq screenheight 60.) (setq idel-chars-availablep nil idel-lines-availablep nil tty-no-upmotionp t overstrike-availablep t) ((lambda (result) (setq DCTLV-tabs-availablep (not (zerop (car result))) result (cdr result)) (setq DCTLV-horznl-pad (car result) result (cdr result)) (setq DCTLV-vertnl-pad (abs (car result)) result (cdr result)) (setq DCTLV-vartab-pad (car result) result (cdr result)) (setq DCTLV-consttab-pad (car result) result (cdr result)) (setq DCTLV-backspace-pad (car result) screenlinelen (cadr result))) (e_pl1_$get_mcs_tty_info)) (setq screenlinelen (cond ((= screenlinelen 79.) 79.) (t (1- screenlinelen)))) (setq DCTLV-one-time-bspad (cond ((< DCTLV-backspace-pad 0)(prog2 0 (- DCTLV-backspace-pad)(setq DCTLV-backspace-pad 0))) (t 0)))) (defun DCTL-position-cursor (x y) (prog () (and (= x X)(= y Y)(return nil)) (and (< X 0)(DCTL-crlf)) ;unrandomize (and (= y Y) (progn (cond ((< X x) ;going forward (cond ((not DCTLV-tabs-availablep) ;no tabs (do xx X (1+ xx)(= xx x)(Rtyo 40))) (t (DCTL-tab-forward X x)))) ((< (- X x) x) (DCTL-delay DCTLV-one-time-bspad) (do xx X (1- xx)(= xx x)(Rtyo 10) (DCTL-delay DCTLV-backspace-pad))) (t (DCTL-cret) (DCTL-position-cursor x Y))) (setq X x) ;y is right by definition (return nil))) ;; Definitely going to a new line at this point (DCTL-nextline) (setq Y y) (DCTL-position-cursor x y))) (defun DCTL-tab-forward (here there) (prog (targ-stops targ-rem cur-stops) (setq targ-stops (// there 10.) targ-rem (\ there 10.)) (setq cur-stops (// here 10.)) ;; ;; Figure out the relative costs. ;; (cond ((and (not (= targ-stops cur-stops)) ;dont even bother (< (+ targ-rem ;spaces to be output (* (- targ-stops cur-stops) ;number of tabs (+ DCTLV-consttab-pad ;constant padding 1 ;the actual tab (fix (*$ 10e0 DCTLV-vartab-pad))))) (- there here))) ;normal cost ;do it (do tabx cur-stops (1+ tabx)(= tabx targ-stops) (Rtyo 11) ;tab (DCTL-delay (+ DCTLV-consttab-pad (fix (*$ 10e0 DCTLV-vartab-pad))))) (setq here (* targ-stops 10.)))) (do xx here (1+ xx)(= xx there)(Rtyo 40)))) (defun DCTL-assert-scpos (x y) (and x (setq X x)) (and y (setq Y y))) (defun DCTL-clear-rest-of-screen ()(DCTL-nextline)) (defun DCTL-nextline ()(Rtyo 12)(DCTL-delay DCTLV-vertnl-pad)) (defun DCTL-kill-line ()(Rtyo 12)(DCTL-delay DCTLV-vertnl-pad)) (defun DCTL-display-char-string (s) (Rprinc s) (setq X (+ X (stringlength s)))) (defun DCTL-cret () (Rtyo 15)(DCTL-delay (+ 3 (fix (*$ (float X) DCTLV-horznl-pad))))(setq X 0)) (defun DCTL-crlf () (DCTL-cret)(DCTL-nextline)) (defun DCTL-delay (n) (do i 1 (1+ i)(> i n)(Rtyo 177)))  regent200.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 26721 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; *********************************************************** ;;; -*-LISP-*- ;;; ;;; ADDS Regent 200 ctl ;;; Ripped off from VIP7800 ctl 02/15/80 by CDT ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-insert-mode-on)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'regent200) (Rtyo 33)(Rprinc "s")(Rtyo 14) (setq X 0 Y 0) (DCTL-prologue)) ;;; Prologue code (defun DCTL-prologue () (setq DCTL-insert-mode-on nil) (Rtyo 14) (setq X 0 Y 0)) ;;; Epilogue code (defun DCTL-epilogue () (setq DCTL-insert-mode-on nil) (Rtyo 33)(Rprinc "s")(Rtyo 14)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 6))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 25)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 32)))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "Y")(Rtyo (+ 37 y))(Rtyo (+ 37 x)) ))) ;;; Output string. (defun DCTL-display-char-string (string) ((lambda (strx) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "F"))) (Rprinc string) (setq X (+ X strx))))) (stringlength string))) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "k")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K")) (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "M"))) (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "l"))) (defun DCTL-insert-char-string (str) (cond (DCTL-insert-mode-on) (t (setq DCTL-insert-mode-on t) (Rtyo 33) (Rprinc "F"))) (Rprinc str) (setq X (+ X (stringlength str)))) (defun DCTL-delete-chars (n) (do i 0 (1+ i)(= i n) (Rtyo 33)(Rprinc "E")))  smarterm.ctl.lisp 11/15/84 1314.0rew 11/15/84 1308.9 26541 ;;; ***************************************************** ;;; * * ;;; * Copyright (C) 1983 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems Inc. * ;;; * * ;;; ***************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; Netronics Smarterm-80 control package ;;; Ripped off from iq120.ctl.lisp by Alberto Magnani 12/3/83. ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (*expr Rprinc Rtyo)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'smarterm) (Rtyo 14) (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 32) (setq X 0 Y 0)) ((and (= x 0)(= y Y)) (Rtyo 15) (setq X 0 Y y)) ((and (= x 0)(< (abs(- Y y)) 3)) (Rtyo 15) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 13)))) (setq X 0 Y y)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 1))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 13)))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33) (Rprinc "=")(Rtyo (+ 40 y))(Rtyo (+ 40 x)) ))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "Y")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "T")) ; Inserting/deleteing lines (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "E"))) (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "R"))) ; Inserting/deleteing characters (defun DCTL-insert-char-string (str) (Rtyo 33)(Rprinc "N") (Rprinc str) (Rtyo 33)(Rprinc "M") (setq X (+ X (stringlength str)))) (defun DCTL-delete-chars (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "W"))) ; That's it guys.  supdup.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 59454 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; supdupctl -- Written by BSG 7/12/78 after he wrote a ;;; SUPDUP user end and discovered he didn't have a server. ;;; From PYZCTL. ;;; ;;; From old aitvctl, from dm2500ctl. ;;; ;;; Define the old %TD codes. (declare (eval (read))) (do x (read)(read)(eq x 'applesauce)(eval x)) (setsyntax '% 'macro 'DCTL-tdcode-macro) (setq DCTL-tdcode-list '( TDEOF 202 TDEOL 203 TDNOP 210 TDMV0 217 TDMOV 200 TDCLR 220 TDBEL 221 TDILP 223 TDDLP 224 TDICP 225 TDDCP 226 )) (do x DCTL-tdcode-list (cddr x)(null x)(putprop (car x)(cadr x) 'tdcode)) (defun cana macro (x) (list 'not (list 'zerop (list 'boole 1 (cadr x)(caddr x))))) (defun DCTL-tdcode-macro () (or (get (read) 'tdcode) (error "Undefined tdcode"))) applesauce (declare (special X Y screenheight tty-no-upmotionp screenlinelen tty-type overstrike-availablep e-quit-transparency)) (declare (special DCTL-ttyopt-word DCTL-aobjn-count)) (declare (special idel-lines-availablep idel-chars-availablep)) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (Rprinc "Multics EMACS Supdup Server") (Rtyo 15)(Rtyo 12) (e_pl1_$dump_output_buffer) (setq DCTL-aobjn-count (lsh (- (DCTL-get-supdup-36-word)) -18.)) (DCTL-get-supdup-36-word) ;TCTYP (setq DCTL-ttyopt-word (DCTL-get-supdup-36-word)) (setq screenheight (DCTL-get-supdup-36-word)) (setq screenheight (min 64. screenheight)) (setq screenlinelen (DCTL-get-supdup-36-word)) (DCTL-get-supdup-36-word) ;TTYROL (setq DCTL-aobjn-count (- DCTL-aobjn-count 5)) (do ()((= DCTL-aobjn-count 0)) (setq DCTL-aobjn-count (1- DCTL-aobjn-count)) (DCTL-get-supdup-36-word)) (setq idel-chars-availablep (cana DCTL-ttyopt-word 000001000000)) (setq idel-lines-availablep (cana DCTL-ttyopt-word 000002000000)) (setq overstrike-availablep (cana DCTL-ttyopt-word 001000000000)) (setq tty-no-upmotionp (not (cana DCTL-ttyopt-word 000400000000))) (setq tty-type 'supdup) (Rtyo %TDNOP) (set-permanent-key '^\ 'supdup-ITP-escape) (set-permanent-key 'esc-@ 'supdup-300-escape) (setq X -777 Y -777) (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) (defun DCTL-get-supdup-36-word () (do ((w 0 (+ (lsh w 6) b)) (b) (i 1 (1+ i))) ((> i 6) w) (setq b (DCTL-gnz-char))))))) (defun DCTL-assert-scpos (x y) (and x (setq X x)) (and y (setq Y y)) (DCTL-tdmov X Y X Y)) (defun DCTL-nextline () (cond ((or (< X 0)(< Y 0)) (DCTL-position-cursor 0 0)) ((= Y (1- screenheight)) (DCTL-position-cursor X 0)) (t (DCTL-position-cursor X (1+ Y)) (DCTL-assert-scpos nil (1- Y))))) ;;; Move terminal's cursor to desired position. ;;; Real work is done in DCTL-real-position-cursor. ;;; This hairy hack is solely for the benefit of printing tty's, ;;; and interfaces Multics EMACS' notion of a prtty "screen" to ITS's. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y))) ;aok, exit. ((not tty-no-upmotionp)(DCTL-real-position-cursor x y)) ((or (< X 0)(< Y 0)) ;randomized? (DCTL-tdmov 50 0 0 1) (DCTL-tdmov 0 0 x y)) ((= Y y)(DCTL-real-position-cursor x y)) ((= y 0)(DCTL-tdmov X 0 X 1) (DCTL-tdmov X y x y)) (t (DCTL-tdmov X (1- y) x y)))) (defun DCTL-tdmov (oldx oldy newx newy) (setq X newx Y newy) (Rtyo %TDMOV) (Rtyo oldy) (Rtyo oldx) (Rtyo newy) (Rtyo newx)) ;;; Actually move a tty cursor. (defun DCTL-real-position-cursor (x y) (Rtyo %TDMV0) (Rtyo y) (Rtyo x) (setq X x Y y)) (defun DCTL-ring-tty-bell () (Rtyo %TDBEL)) (defprop supdup t tintinnabulum-ipsum-meum-sono) ; Output string. (defun DCTL-display-char-string (string) ((lambda (len) (setq X (+ X len)) (Rprinc string)) (stringlength string))) ; Clear whole screen. (defun DCTL-clear-rest-of-screen () (cond (tty-no-upmotionp (DCTL-nextline)) (t (Rtyo %TDEOF)))) ; Go to next line on non-moveuppable terminals. (defun DCTL-nextline () (cond ((= Y (1- screenheight)) (DCTL-position-cursor X 0)) (t (DCTL-position-cursor X (1+ Y))))) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo %TDEOL)) ; Insert character string in line at current position. (defun DCTL-insert-char-string (str) ((lambda (len) (Rtyo %TDICP) (Rtyo len) (Rprinc str) (setq X (+ X len))) (stringlength str))) ; Delete characters from current position in line. (defun DCTL-delete-chars (n) (Rtyo %TDDCP) (Rtyo n)) ; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (Rtyo %TDILP) (Rtyo n)) ; Delete n lines at current position. (defun DCTL-delete-lines (n) (Rtyo %TDDLP) (Rtyo n)) ; Intelligent terminal protocol Handlers. (defun DCTL-gnz-char () (do x (e_pl1_$get_char)(e_pl1_$get_char) nil (cond ((= x 377)((lambda (e-quit-transparency) (telnet-loser (DCTL-gnz-char))) 'leave-it)(setq x -1))) (or (< x 0)(return x)))) (defun supdup-300-escape () ((lambda (c) (cond ((= c 301)(quit)) ((= c 302)(do x (DCTL-gnz-char)(DCTL-gnz-char)(= x 0))) (t () ))) (DCTL-gnz-char))) (defun supdup-ITP-escape () (real-supdup-ITP-escape (DCTL-gnz-char))) (defun real-supdup-ITP-escape (c) (cond ((= c 34)) ;too bad ((= c 003) ;PIATY (do ()(nil) ((lambda (d) (cond ((= d 34)((lambda(e) (cond ((= e 003)) (t (real-supdup-ITP-escape e)))) (DCTL-gnz-char))) (t (full-redisplay) (process-char d) (return nil)))) (DCTL-gnz-char)))) ((= c 020) ;^P (setq Y (DCTL-gnz-char) X (DCTL-gnz-char))) (t ((lambda (d) (setq c (boole 1 3 c));meta, control (and (cana d 1)(setq d (- d 100))) (xec-cmd-triplet (lsh c -1) d nil)) (DCTL-gnz-char)))))  supdup_output.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 73998 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; supdup_outputctl -- from PYZctl BSG 10/1/78 ;;; PYZctl - Protocols of the Youngers of Zion ;;; Which BSG and DLW scratched out on notes during an otherwise ;;; rowdy SIPB meeting. ;;; From old aitvctl, from dm2500ctl. ;;; BSG & DLW 6/26/78 ;;; Supdup Block negotiation added by BSG, 8/10/78, ;;; who also hand-coded the MIDAS-coded ITS-side that day. ;;; ;;; Modified 29 April 1981 by WMY, BARMAR and DCP to use the SUPDUP ;;; scroll-region operation, and to clean up some names. (declare (defpl1 e_pl1_$return_supdup_info "" (return bit (36.))(return fixed bin (35.))(return fixed bin (35.)))) (declare (defpl1 e_pl1_$set_multics_tty_modes "")) (declare (eval (read))) (do x (read)(read)(eq x 'applesauce)(eval x)) (setsyntax '% 'macro 'DCTL-tdcode-macro) ;;; Define the old %TD codes. (setq DCTL-tdcode-list '( TDMOV 200 ; absolute cursor position: old_x old_y new_x new_y TDEOF 202 ; clear to end of screen (file) TDEOL 203 ; clear to end of line TDNOP 210 ; no-op TDMV0 217 ; absolute cursor position: new_x new_y TDCLR 220 ; clear whole screen and home TDBEL 221 ; ding dong TDILP 223 ; insert lines: number_of_lines TDDLP 224 ; delete lines: number_of_lines TDICP 225 ; insert characters: number_of_characters TDDCP 226 ; delete characters: number_of_characters TDRSU 232 ; region scroll up: lines_in_region lines_to_scroll TDRSD 233 ; region scroll down: lines_in_region lines_to_scroll ;;; Protocols of the Elders of ARPA. IAC 377 ; IAC escape code for telnet connections SB 250. ; supdup subnegotiation begin SE 240. ; supdup subnegotiation end SUPDUP-OUTPUT 22. )) (do x DCTL-tdcode-list (cddr x)(null x)(putprop (car x)(cadr x) 'tdcode)) (defun DCTL-tdcode-macro () (or (get (read) 'tdcode) (error "Undefined tdcode"))) (defun cana macro (x) (list 'not (list 'zerop (list 'boole 1 (cadr x)(caddr x))))) applesauce (declare (special X Y screenheight screenlinelen tty-type overstrike-availablep)) (declare (special DCTL-ttyopt-word tty-no-upmotionp)) (declare (special idel-lines-availablep idel-chars-availablep region-scroll-availablep)) ;;; Initialize terminal and terminal control package. (defun DCTL-init () ((lambda (sdparms) (setq DCTL-ttyopt-word (car sdparms) screenlinelen (cadr sdparms) screenheight (min 60. (caddr sdparms)))) (e_pl1_$return_supdup_info)) ;; Since very bad stuff happens if the above code fails, check it out. (cond ((or (zerop DCTL-ttyopt-word) (zerop screenlinelen) (zerop screenheight)) (e_pl1_$set_multics_tty_modes) (princ "Invalid SUPDUP info:") (print (list DCTL-ttyopt-word screenlinelen screenheight)) (terpri) (quit))) ;; decode the TTYOPT word, see MC:.INFO.;ITS TTYVAR for info (setq region-scroll-availablep (cana DCTL-ttyopt-word 000000000004)) (setq idel-lines-availablep (cana DCTL-ttyopt-word 000002000000)) (setq idel-chars-availablep (cana DCTL-ttyopt-word 000001000000)) (setq overstrike-availablep (cana DCTL-ttyopt-word 001000000000)) (setq tty-no-upmotionp (not (cana DCTL-ttyopt-word 000400000000))) (setq tty-type 'supdup_output) (setq X -777 Y -777) (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) (defun DCTL-assert-scpos (x y) (and x (setq X x)) (and y (setq Y y)) (DCTL-tdmov X Y X Y)) ; Go to next line on non-moveuppable terminals. (defun DCTL-nextline () (cond ((or (< X 0)(< Y 0)) (DCTL-position-cursor 0 0)) ((= Y (1- screenheight)) (DCTL-position-cursor X 0)) (t (DCTL-position-cursor X (1+ Y)) (DCTL-assert-scpos nil (1- Y))))) ;;; Move terminal's cursor to desired position. ;;; Real work is done in DCTL-real-position-cursor. ;;; This hairy hack is solely for the benefit of printing tty's, ;;; and interfaces Multics EMACS' notion of a prtty "screen" to ITS's. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y))) ;aok, exit. ((not tty-no-upmotionp)(DCTL-real-position-cursor x y)) ((or (< X 0)(< Y 0)) ;randomized? (DCTL-tdmov 50 0 0 1) (DCTL-tdmov 0 0 x y)) ((= Y y)(DCTL-real-position-cursor x y)) ((= y 0)(DCTL-tdmov X 0 X 1) (DCTL-tdmov X y x y)) (t (DCTL-tdmov X (1- y) x y)))) (defun DCTL-tdmov (oldx oldy newx newy) (setq X newx Y newy) (DCTL-begin-subnegotiation 5) (Rtyo %TDMOV) (Rtyo oldy) (Rtyo oldx) (Rtyo newy) (Rtyo newx) (DCTL-out-scpos)) ;;; Actually move a tty cursor. (defun DCTL-real-position-cursor (x y) (DCTL-begin-subnegotiation 3) (Rtyo %TDMV0) (Rtyo y) (Rtyo x) (setq X x Y y) (DCTL-out-scpos)) (defun DCTL-ring-tty-bell () (DCTL-begin-subnegotiation 1) (Rtyo %TDBEL) (DCTL-out-scpos)) (defprop supdup_output t tintinnabulum-ipsum-meum-sono) ; Output string. (defun DCTL-display-char-string (string) ((lambda (len) (DCTL-begin-subnegotiation len) (setq X (+ X len)) (Rprinc string) (DCTL-out-scpos)) (stringlength string))) ; Clear whole screen. (defun DCTL-clear-rest-of-screen () (cond (tty-no-upmotionp (DCTL-nextline)) (t (DCTL-begin-subnegotiation 1) (Rtyo (cond ((and (= X 0)(= Y 0)) %TDCLR) (t %TDEOF))) (DCTL-out-scpos)))) ; Clear to end of line. (defun DCTL-kill-line () (cond (tty-no-upmotionp ;do nextline op (DCTL-nextline)) (t (DCTL-begin-subnegotiation 1) (Rtyo %TDEOL) (DCTL-out-scpos)))) ; Insert character string in line at current position. (defun DCTL-insert-char-string (str) ((lambda (len) (DCTL-begin-subnegotiation (+ 2 len)) (Rtyo %TDICP) (Rtyo len) (Rprinc str) (setq X (+ X len)) (DCTL-out-scpos)) (stringlength str))) ; Delete characters from current position in line. (defun DCTL-delete-chars (n) (DCTL-begin-subnegotiation 2) (Rtyo %TDDCP) (Rtyo n) (DCTL-out-scpos)) ; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (DCTL-begin-subnegotiation 2) (Rtyo %TDILP) (Rtyo n) (DCTL-out-scpos)) ; Delete n lines at current position. (defun DCTL-delete-lines (n) (DCTL-begin-subnegotiation 2) (Rtyo %TDDLP) (Rtyo n) (DCTL-out-scpos)) ;;; Scroll region N lines long up m lines (defun DCTL-scroll-up-region (nlines bottom-line) (DCTL-begin-subnegotiation 3) (Rtyo %TDRSU) (Rtyo (1+ (- bottom-line Y))) (Rtyo nlines) (DCTL-out-scpos)) ;;; Scroll region N lines long down m lines (defun DCTL-scroll-down-region (nlines bottom-line) (DCTL-begin-subnegotiation 3) (Rtyo %TDRSD) (Rtyo (1+ (- bottom-line Y))) (Rtyo nlines) (DCTL-out-scpos)) ;;; Internal frobula used by above. Begins the SUPDUP-OUTPUT subnegotiation. ;;; This includes the proper TDcodes, and constant 2, then the number of ;;; TDcodes coming after this. (defun DCTL-begin-subnegotiation (tdcode-count) (mapc 'Rtyo '(%IAC %SB %SUPDUP-OUTPUT 2)) (Rtyo tdcode-count)) ;better be not 377 or other funnies. (defun DCTL-out-scpos () (cond ((or (> X screenlinelen) (< X 0) (> Y (1- screenheight)) (< Y 0)) (print "=====> ") (prin1 (cons X Y)) (break "DCTL-out-scpos has seen losing X and/or Y." t))) (Rtyo X) (Rtyo Y) ;; end the subnegotiation (mapc 'Rtyo '(%IAC %SE)))  tdv2220.ctl.lisp 08/20/86 2312.9rew 08/20/86 2256.7 42399 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; *********************************************************** ;;; HISTORY COMMENTS: ;;; 1) change(86-04-23,Margolin), approve(86-04-23,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added *expr declarations to prevent compiler warnings, and removed the ;;; CR characters before newlines. ;;; END HISTORY COMMENTS ;;; ;;; TDV2220 control package ;;; bb 1981-08-19 (%include e-macros) (declare (special X Y screenheight screenlinelen ospeed)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep)) (declare (special region-scroll-availablep)) (declare (*expr Rprinc Rtyo)) ;;; Macro to output escape sequence (defun tdv2220-escape () (Rtyo 33) (Rprinc "[")) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 ((lambda (have-output) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi))))) nil)) ;;; Output padding, based on n pad characters at 9600-baud (defun DCTL-pad (n) (do-times (// (* n ospeed) 960.) (Rtyo 0))) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq idel-lines-availablep t idel-chars-availablep t) (setq region-scroll-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'tdv2220) (DCTL-prologue) (DCTL-home-cursor) (DCTL-clear-rest-of-screen)) ;;; Initialization that must also be done after a QUIT (defun DCTL-prologue () (tdv2220-escape) (Rprinc "36l")) ;;; Restore terminal to outside state (defun DCTL-epilogue () (tdv2220-escape) (Rprinc "36h")) ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (let ((deltax (- x X)) (deltay (- y Y))) (cond ((= deltay 0) (cond ((= deltax 0) nil) ((> deltax 0) (tdv2220-escape) (DCTL-outdec deltax) (Rprinc "C")) ((= x 0) (Rtyo 15)) ;move left (t (tdv2220-escape) (DCTL-outdec (- deltax)) (Rprinc "D")))) ((= deltax 0) (cond ((> deltay 0) (tdv2220-escape) (DCTL-outdec deltay) (Rprinc "B")) (t (tdv2220-escape) (DCTL-outdec (- deltay)) (Rprinc "A")))) (t (tdv2220-absolute-position x y))) (setq X x Y y))) ;;; Perform absolute cursor positioning (defun tdv2220-absolute-position (x y) (tdv2220-escape) (DCTL-outdec (1+ y)) ;both arguments plus (Rprinc ";") ;semicolon must be present (DCTL-outdec (1+ x)) (Rprinc "H")) ;;; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ;;; Home cursor to upper left corner. (defun DCTL-home-cursor () (setq X 0 Y 0) (tdv2220-escape) (Rprinc "H")) ;direct cursor address ;without args. ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (tdv2220-escape) (Rprinc "J")) ;;; Clear to end of line. (defun DCTL-kill-line () (tdv2220-escape) (Rprinc "K")) ;;; Insert n lines at the current cursor position (defun DCTL-insert-lines (n) (tdv2220-escape) (DCTL-outdec n) (Rprinc "L") (DCTL-pad (* n 10.))) ;;; Delete n lines at the current cursor position (defun DCTL-delete-lines (n) (tdv2220-escape) (DCTL-outdec n) (Rprinc "M") (DCTL-pad (* n 10.))) ;;; Insert string at the current cursor position (defun DCTL-insert-char-string (string) (tdv2220-escape) (DCTL-outdec (stringlength string)) (Rprinc "@") ;Insert blanks (DCTL-display-char-string string)) ;and print the string. (defun DCTL-delete-chars (n) (tdv2220-escape) (DCTL-outdec n) (Rprinc "P"))  tek4023.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 15039 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; TEK4023 pseudokludge ;;; ;;; BSG 3/21/78 from DD4000ctl ;;; BSG 2/14/80 for tty-no-cleolp :. no more kludge. ;;; (declare (special X Y screenheight screenlinelen)) (declare (special idel-lines-availablep idel-chars-availablep tty-type tty-no-cleolp)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil tty-no-cleolp t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'tek4023) (DCTL-clear-rest-of-screen)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 28.)(Rtyo 32.)(Rtyo 32.) (setq X 0 Y 0)) (t (Rtyo 28.)(Rtyo (+ 40 x))(Rtyo (+ 40 y)) (setq X x Y y)))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () ;cheat- no eos, just home (Rtyo 33)(Rtyo 14)(mapc 'Rtyo '(0 0 0 0)) (setq X 0 Y 0))  tek4025.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 36162 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; Tektronix 4025 control package ;;; Snarfed from VIP7800 package, ;;; In turn ripped off from VIP7200ctl ;;; ;;; Roy A. Leban, January 15, 1979. ;;; ;;; Notes on current problems with this implementation: ;;; 1) It is possible to have screens > 33 lines. This is not done. ;;; 2) User setable command character desirable. (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (special ctl-close-necessaryp)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq screenheight 33. screenlinelen 79.) (setq tty-type 'tek4025)(setq ctl-close-necessaryp t) (Rtyo 37)(Rprinc "wor 33")(Rtyo 15) ;Work space of 33 lines (Rtyo 37)(Rprinc "wor")(Rtyo 15) ;Go to top of work space. (setq X 0 Y 33)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 37)(Rprinc "jum")(Rtyo 15) (setq X 0 Y 0)) ((= x 0) ; column 1 of a line. (Rtyo 37)(Rprinc "jum ") (DCTL-4025-outnum (+ y 1)) (Rtyo 15) (setq X x Y y)) ((and (= x X)(> Y y)) ; same column- up. (Rtyo 37)(Rprinc "up ") (DCTL-4025-outnum (- Y y)) (Rtyo 15) (setq Y y)) ((and (= x X)(< Y y)) ; same column- down. (Rtyo 37)(Rprinc "dow ") (DCTL-4025-outnum (- y Y)) (Rtyo 15) (setq Y y)) ((and (= y Y)(> X x)) ; same line- left. (Rtyo 37)(Rprinc "lef ") (DCTL-4025-outnum (- X x)) (Rtyo 15) (setq X x)) ((and (= y Y)(< X x)) ; same line- right. (Rtyo 37)(Rprinc "rig ") (DCTL-4025-outnum (- x X)) (Rtyo 15) (setq X x)) ;;else do a jump with both line and column. (t (setq X x Y y) (Rtyo 37)(Rprinc "jum ") (DCTL-4025-outnum (+ y 1)) (Rprinc ",") (DCTL-4025-outnum (+ x 1)) (Rtyo 15)))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 37)(Rprinc "dli 33") ; max of 33 lines left in buffer. (Rtyo 15)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 37)(Rprinc "dch 80") ; max of 80 chars left in line. (Rtyo 15)) (defun DCTL-insert-lines (n) (Rtyo 37)(Rprinc "ili ") ; Note the inherent problem with this. (DCTL-4025-outnum n) ; ili causes lines at the bottom to (Rtyo 15)) ; roll of the screen but not out of ; the terminal. (defun DCTL-delete-lines (n) (Rtyo 37)(Rprinc "dli ") ; first delete the lines, (DCTL-4025-outnum n) (Rtyo 15) (DCTL-insert-lines n)) ; then rejustify with inserts. (defun DCTL-insert-char-string (str) (Rtyo 37)(Rprinc "ich")(Rtyo 15) (Rprinc str) ; should automatically revert out. if not "!wor" (setq X (+ X (stringlength str)))) (defun DCTL-delete-chars (n) (Rtyo 37)(Rprinc "dch ") (DCTL-4025-outnum n) (Rtyo 15)) (defun DCTL-4025-outnum (n) (cond ((> n 9.) (Rtyo (+ 60 (// n 10.))) (setq n (- n (* 10. (// n 10.)))))) (Rtyo (+ 60 n))) (defun DCTL-close-screen () (Rtyo 37)(Rprinc "wor 0")(Rtyo 15))  teleray1061.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 26172 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; TELERAY 1061 control package ;;; GMP, 08/14/78 from VT52 package ;;; (declare (special X Y screenheight screenlinelen ospeed)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t screenheight 24. screenlinelen 79. tty-type 'teleray1061 X -777 Y -777) (DCTL-position-cursor 0 0) (DCTL-clear-rest-of-screen)) ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X) (= y Y)) nil) ((and (= x 0) (= y 0)) (Rtyo 33) (Rprinc "H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x)) (abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex) (= ex x) (Rtyo 33) (Rprinc "C"))) ((< x X) (do ex x (1+ ex) (= ex X) (Rtyo 010)))) (cond ((< Y y) (do wy Y (1+ wy) (= wy y) (Rtyo 33) (Rprinc "B"))) ((< y Y) (do wy y (1+ wy) (= wy Y) (Rtyo 33) (Rprinc "A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33) (Rprinc "Y") (Rtyo (+ 40 y)) (Rtyo (+ 40 x))))) ;;; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33) (Rprinc "J") (DCTL-pad 90.)) ;;; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33) (Rprinc "K")) ;;; Insert character string in line at current position. (defun DCTL-insert-char-string (str) (do i (stringlength str) (1- i) (= i 0) (Rtyo 33) (Rprinc "P")) (Rprinc str) (setq X (+ X (stringlength str)))) ;;; Delete characters from current position in line. (defun DCTL-delete-chars (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "Q"))) ;;; Insert n blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "L") (DCTL-pad 60.)) (setq X 0)) ;;; Delete n lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i) (> i n) (Rtyo 33) (Rprinc "M") (DCTL-pad 60.)) (setq X 0)) ;;; Send pad characters to wait specified number of milliseconds (defun DCTL-pad (n) (do i (1+ (// (* n ospeed) 1000.)) (1- i) (= i 0) (Rtyo 0)))  tvi912.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 18558 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; TVI912 Controller - ripped off from TVI920 controller. ;;; written by R. Jarrell Aug. 1982 ;;; (declare (special X Y screenheight screenlinelen tty-type ospeed)) (declare (special idel-lines-availablep idel-chars-availablep)) ;;; initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'tvi912) (Rtyo 36)(Rtyo 33)(Rprinc "Y") (setq X 0 Y 0)) ;;; prologue and epilogue will go here ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 36) (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 14))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 13)))) (setq X x Y y)) ;; Direct cursor addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "=") (Rtyo (+ 40 y))(Rtyo (+ 40 x))))) ;;; Output string. (defun DCTL-display-char-string (string) (Rprinc string) (setq X (+ X (stringlength string)))) ;;; clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "Y")) ;;; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "T"))  tvi920.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 37827 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; TVI920 control ripped off from ADM3A, TELERAY1061 ;;; by CLS 06/20/80 ;;; modified 08/11/80 to fix insert-chars ;;; modified 09/05/80 to add pad control for =>1200 baud ;;; modified 09/18/80 by CDT to pad efficiently at all speeds ;;; The TVI920C has a 240-character writebehind buffer that can be used to ;;; good effect by carefully under-padding operations that need padding. ;;; Since there is no way to underpad these things deterministically (since ;;; emacs never lets you know when it has gone blocked for read and therefore ;;; you really don't know when the buffer is likely to have emptied itself out) ;;; we cautiously underpad by only slight amounts. (declare (special X Y screenheight screenlinelen tty-type ospeed)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (special DCTL-writebehind-buf-used)) ;;; initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'tvi920) (DCTL-clear-writebehind-buf) (Rtyo 36)(Rtyo 33)(Rprinc "Y") (setq X 0 Y 0)) ;;; prologue and epilogue will go here ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 36) (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 14))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 13)))) (setq X x Y y)) ;; Direct cursor addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "=") (Rtyo (+ 40 y))(Rtyo (+ 40 x))))) ;;; Output string. (defun DCTL-display-char-string (string) (Rprinc string) (setq X (+ X (stringlength string)))) ;;; clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "Y")) ;;; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "T")) ;;; Insert lines n blank lines at current position. (defun DCTL-insert-lines (n) (DCTL-clear-writebehind-buf) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "E") (DCTL-underpad 78.)) (setq X 0) (DCTL-clear-writebehind-buf)) ;;; Delete lines. (defun DCTL-delete-lines (n) (DCTL-clear-writebehind-buf) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "R") (DCTL-underpad 78.)) (setq X 0) (DCTL-clear-writebehind-buf)) ;;; Insert Characters (defun DCTL-insert-char-string (str) (DCTL-clear-writebehind-buf) (do i (stringlength str) (1- i) (= i 0) (Rtyo 33) (Rprinc "Q") (DCTL-underpad 19.)) (Rprinc str) (DCTL-clear-writebehind-buf) (setq X (+ X (stringlength str)))) ;;; Delete Characters. (defun DCTL-delete-chars (n) (DCTL-clear-writebehind-buf) (do i 0 (1+ i)(= i n) (Rtyo 33)(Rprinc "W") (DCTL-underpad 19.)) (DCTL-clear-writebehind-buf)) ;;; Send pad characters to wait specified number of milliseconds ;;; We underpad to take advantage of the 240-char writebehind buffer in the ;;; terminal. We underpad by 1/3 the buffer and hope it works. (defun DCTL-underpad (n) (do i (1+ (// (* n ospeed) 1000.)) (1- i) (= i 0) (setq DCTL-writebehind-buf-used (1+ DCTL-writebehind-buf-used)) (cond ((> DCTL-writebehind-buf-used 80.)(Rtyo 0))))) (defun DCTL-clear-writebehind-buf () (setq DCTL-writebehind-buf-used 0))  versaterm.ctl.lisp 10/07/88 1209.8rew 10/07/88 1208.9 85716 ;;; ****************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Bull Inc., 1988 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; ****************************************************** ;;; HISTORY COMMENTS: ;;; 1) change(86-08-15,Coppola), approve(86-08-15,MCR7516), ;;; audit(86-09-02,GDixon), install(86-09-04,MR12.0-1146): ;;; Add Emacs ctl for Versaterm (Macintosh VT100 Term.) ;;; 2) change(88-01-16,GDixon), approve(88-09-20,MCR8002), ;;; audit(88-10-07,Blair), install(88-10-07,MR12.2-1141): ;;; A) Added support for longer versaterm line and page lengths. The ;;; user's current tty_ page and line length modes are used by Emacs. ;;; B) Changed DCTL-clear-rest-of-screen to reset scroll mode. This ;;; allows escape via ^X CR to scroll up the Emacs buffers as nonEmacs ;;; output appears. ;;; C) Changed all places which reset scroll mode to use the proper ;;; terminal size (either 80 char lines or 132 char lines). ;;; D) Remove all region scrolling functions, as they have never worked ;;; and were never enabled. Emacs does not properly maintain X and Y ;;; variables, which the scrolling software depends upon. ;;; END HISTORY COMMENTS ;;; ;;; ;;; VersaTerm control package (Macintosh VT100/102 Terminal Emulator) ;;; Created: 20 May 1983 by B. Margolin from VT132 CTL ;;; Modified: 2 November 1984 by B. Margolin to remove unexecuted ;;; forms from DCTL-clear-rest-of-screen and DCTL-kill-line. ;;; ;;; May, 1986 by R. Coppola for VersaTerm (tm). Works only for ;;; VersaTerm Rev2.20 and higher. (%include e-macros) (declare (*expr Rprinc Rtyo DCTL-standard-set-modes)) (declare (special X Y screenheight screenlinelen ospeed given-tty-type)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-underline-mask)) (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom DCTL-insert-mode-on)) (declare (special DCTL-oflow-enabled DCTL-have-nonstandard-setmodes)) (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned))) (declare (defpl1 get-screen-size "vt1xx_ctl_util_$get_screen_size" (return fixed bin) (return fixed bin))) (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow "")) ;;; Macro to output escape sequence (defun vt102-escape macro (form) (list 'Rprinc (apply 'catenate (cons (ItoC 33) (cons "[" (cdr form)))))) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 (let ((have-output)) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi)))))) ;;; Output padding, based on n pad characters at 9600-baud (defun DCTL-pad (n) (or DCTL-oflow-enabled ;flow control should do it (do-times (// (* n ospeed) 960.) (Rtyo 0)))) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (let ((screensize (get-screen-size))) (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq DCTL-underline-mask t) (setq screenheight (cadr screensize) screenlinelen (car screensize)) (setq idel-lines-availablep t idel-chars-availablep t) (setq DCTL-oflow-enabled (memq given-tty-type '(versaterm_oflow versaterm_132c_oflow versaterm220_oflow versaterm220_132c_oflow))) (setq tty-type 'versaterm) (DCTL-prologue) (DCTL-home-cursor) (DCTL-clear-rest-of-screen))) ;;; Initialization that must also be done after a QUIT (defun DCTL-prologue () (Rtyo 33) (Rprinc "<") ;set ANSI mode from VT52 mode (vt102-escape "?4l") ;reset scroll mode (jump) (vt102-escape "?6l") ;reset absolute origin mode (vt102-escape "r") ;reset scroll region (vt102-escape "20l") ;turn off auto-CRLF (cond ((> screenlinelen 100.) (vt102-escape "?3h")) (t (vt102-escape "?3l"))) (DCTL-pad 102.) (setq DCTL-insert-mode-on nil) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) ;;; Restore terminal to outside state (defun DCTL-epilogue () (vt102-escape "?4l") ;reset scroll mode (jump) (vt102-escape "?6l") ;reset absolute origin mode (vt102-escape "r") ;reset scroll region (DCTL-pad 4) (setq DCTL-insert-mode-on nil)) ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (vt102-absolute-position x y) (setq X x Y y)) ;;; Perform absolute cursor positioning (defun vt102-absolute-position (x y) (vt102-escape) (if (not (= y 0)) (DCTL-outdec (1+ y))) (if (not (= x 0)) (Rprinc ";") (DCTL-outdec (1+ x))) (Rprinc "H")) ;;; Output string. (defun DCTL-display-char-string (string) (let ((strx (stringlength string))) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil))) (DCTL-output-underlined-string string) (setq X (+ X strx)))))) (defun DCTL-output-underlined-string (string) (cond ((zerop (not_ascii_ string)) ;optimize standard string (Rprinc string)) (t (let ((un nil)) (mapc '(lambda (ch) (cond ((< (CtoI ch) 400) ;normal char (and un (vt102-escape "m")) ;out of underline mode (setq un nil) (Rprinc ch)) (t ;underlined char (400-bit set) (or un (vt102-escape "4m")) (setq un t) (Rtyo (- (CtoI ch) 400))))) (explodec string)) (and un (vt102-escape "m")))))) ;;; Home cursor to upper left corner. (defun DCTL-home-cursor () (setq X 0 Y 0) (vt102-escape H)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (vt102-escape "?4l") ;reset scroll mode (jump) (vt102-escape "?6l") ;reset absolute origin mode (vt102-escape "r") ;reset scroll region (vt102-escape J) (cond ((> screenlinelen 100.) ;set proper screen width (vt102-escape "?3h")) (t (vt102-escape "?3l")))) ;;; Clear to end of line. (defun DCTL-kill-line () (vt102-escape K)) ;;; Insert n lines at the current cursor position (defun DCTL-insert-lines (n) (do-times n (vt102-escape "L"))) ;;; Delete n lines at the current cursor position (defun DCTL-delete-lines (n) (do-times n (vt102-escape "M"))) ;;; Insert given text at the cursor (defun DCTL-insert-char-string (string) (vt102-escape) (DCTL-outdec (stringlength string)) (Rprinc "@") (DCTL-output-underlined-string string) (setq X (+ X (stringlength string)))) ;;; Delete N characters at the cursor (defun DCTL-delete-chars (n) (vt102-escape) (and (> n 1) (DCTL-outdec n)) (Rprinc "P"))) ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary (or (and (boundp 'DCTL-have-nonstandard-setmodes) DCTL-have-nonstandard-setmodes) (progn (putprop 'DCTL-standard-set-modes (get 'e_pl1_$set_emacs_tty_modes 'subr) 'subr) (setq DCTL-have-nonstandard-setmodes t))) (defun e_pl1_$set_emacs_tty_modes () (DCTL-standard-set-modes) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) (setq DCTL-oflow-enabled nil) ;above gets called once before DCTL-init ;;; Load in special key definitions for VT1XX terminals (cond ((status feature Emacs) ;but only in Emacs (load (list (car (namelist (truename infile))) "vt1xx_keys_")))) ;;; REGION SCROLLING DOESN'T WORK because X and Y variables aren't maintained properly by emacs. ;;; Define the bounds of the scroll region. Relative cursor ;;; movement can only be done within this region. ;;;(defun DCTL-define-scroll-region (top bottom) ;;; (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom))) ;;; (t (setq scroll-region-top top scroll-region-bottom bottom) ;;; (Rtyo 33) (Rprinc "7") ;push cursor position ;;; (Rtyo 33) (Rprinc "[") ;redefine scroll region (homes) ;;; (cond ((not (= top 0)) ;;; (DCTL-outdec (1+ top)))) ;;; (cond ((not (= bottom (1- screenheight))) ;;; (Rprinc ";") ;;; (DCTL-outdec (1+ bottom)))) ;;; (Rprinc "r") ;;; (Rtyo 33) (Rprinc "8") ;pop cursor position ;;; (DCTL-pad 5.)))) ;;; Move text in scroll region up n lines (inserts whitespace at bottom) ;;;(defun DCTL-scroll-up-region (nlines bottom) ;;; (DCTL-define-scroll-region Y bottom) ;;; (let ((oldy Y)) ;;; (Rtyo 33) (Rprinc "7") ;save cursor position ;;; (DCTL-position-cursor 0 bottom) ;;; (do-times nlines ;;; (Rtyo 12) (DCTL-pad 5.)) ;;; (Rtyo 33) (Rprinc "8") ;;; (setq Y oldy))) ;;; Move text in scroll region down n lines (inserts whitespace at top) ;;;(defun DCTL-scroll-down-region (nlines bottom) ;;; (DCTL-define-scroll-region Y bottom) ;;; (do-times nlines ;;; (Rtyo 33) (Rprinc "M") (DCTL-pad 5.)))  versaterm210.ctl.lisp 09/04/86 1133.0rew 09/04/86 1056.9 83619 ;;; ****************************************************** ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; ****************************************************** ;;; HISTORY COMMENTS: ;;; 1) change(86-08-15,Coppola), approve(86-08-15,MCR7516), ;;; audit(86-09-03,GDixon), install(86-09-04,MR12.0-1146): ;;; Add Emacs ctl for Versaterm (Macintosh VT100 Term.) ;;; END HISTORY COMMENTS ;;; ;;; ;;; VersaTerm control package (Macintosh VT100/102 Terminal Emulator) ;;; Created: 20 May 1983 by B. Margolin from VT132 CTL ;;; Modified: 2 November 1984 by B. Margolin to remove unexecuted ;;; forms from DCTL-clear-rest-of-screen and DCTL-kill-line. ;;; ;;; May, 1986 by R. Coppola for VersaTerm (tm). Intended for ;;; use with versions 2.10 and lower, but will work with ;;; later revisions. (%include e-macros) (declare (*expr Rprinc Rtyo DCTL-standard-set-modes)) (declare (special X Y screenheight screenlinelen ospeed given-tty-type)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-underline-mask)) (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom DCTL-insert-mode-on)) (declare (special DCTL-oflow-enabled DCTL-have-nonstandard-setmodes)) (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned))) (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow "")) ;;; Macro to output escape sequence (defun vt102-escape macro (form) (list 'Rprinc (apply 'catenate (cons (ItoC 33) (cons "[" (cdr form)))))) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 (let ((have-output)) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi)))))) ;;; Output padding, based on n pad characters at 9600-baud (defun DCTL-pad (n) (or DCTL-oflow-enabled ;flow control should do it (do-times (// (* n ospeed) 960.) (Rtyo 0)))) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq DCTL-underline-mask t) (setq idel-lines-availablep t idel-chars-availablep t) (setq region-scroll-availablep nil) (setq screenheight 24.) (setq screenlinelen 79.) (setq tty-type 'versaterm210) (DCTL-prologue) (DCTL-home-cursor) (DCTL-clear-rest-of-screen)) ;;; Initialization that must also be done after a QUIT (defun DCTL-prologue () (Rtyo 33) (Rprinc "<") ;set ANSI mode from VT52 mode (vt102-escape "?4l") ;reset scroll mode (jump) (vt102-escape "?6l") ;reset absolute origin mode (vt102-escape "r") ;reset scroll region (vt102-escape "20l") ;turn off auto-CRLF (cond ((= screenlinelen 131.) ;set proper screen width (vt102-escape "?3h")) (t (vt102-escape "?3l"))) (DCTL-pad 102.) (setq scroll-region-top 0 scroll-region-bottom (1- screenheight)) (setq DCTL-insert-mode-on nil) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) ;;; Restore terminal to outside state (defun DCTL-epilogue () (vt102-escape "r") ;reset scroll region (DCTL-pad 4) (setq DCTL-insert-mode-on nil)) ;;; Move terminal's cursor to desired position. ;;; Relative cursor movement commands are confined to the current scrolling region. Absolute movement commands can ;;; address the entire screen if if Origin Mode is reset. Missing arguments in the absolute positioning command default ;;; to one. Relative commands can be used if the scroll boundaries are examined. (defun DCTL-position-cursor (x y) (let ((deltax (- x X)) (deltay (- y Y))) (cond ((= deltay 0) (cond ((= deltax 0) nil) ((> deltax 0) ;move right (vt102-escape) (if (not (= deltax 1)) (DCTL-outdec deltax)) (Rprinc "C")) (t (cond ((= x 0) (Rtyo 15) (DCTL-pad (1+ (// X 4)))) ;move left ((< (- deltax) 4) (do-times (- deltax) (Rtyo 10))) (t (vt102-escape) (DCTL-outdec (- deltax)) (Rprinc "D")))))) ((= deltax 0) ;;make sure scroll region doesn't screw us. (cond ((or (and (> y scroll-region-bottom) (not (> Y scroll-region-bottom))) (and (< y scroll-region-top) (not (< Y scroll-region-top)))) (vt102-absolute-position x y)) ((> deltay 0) ;move down (cond ((< deltay 4) (do-times deltay (Rtyo 12))) (t (vt102-escape) (DCTL-outdec deltay) (Rprinc "B")))) (t (cond ((= deltay -1) ;move up (Rtyo 33) (Rprinc "M")) (t (vt102-escape) (DCTL-outdec (- deltay)) (Rprinc "A")))))) (t (vt102-absolute-position x y))) (setq X x Y y))) ;;; Perform absolute cursor positioning (defun vt102-absolute-position (x y) (vt102-escape) (if (not (= y 0)) (DCTL-outdec (1+ y))) (if (not (= x 0)) (Rprinc ";") (DCTL-outdec (1+ x))) (Rprinc "H")) ;;; Output string. (defun DCTL-display-char-string (string) (let ((strx (stringlength string))) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil))) (DCTL-output-underlined-string string) (setq X (+ X strx)))))) (defun DCTL-output-underlined-string (string) (cond ((zerop (not_ascii_ string)) ;optimize standard string (Rprinc string)) (t (let ((un nil)) (mapc '(lambda (ch) (cond ((< (CtoI ch) 400) ;normal char (and un (vt102-escape "m")) ;out of underline mode (setq un nil) (Rprinc ch)) (t ;underlined char (400-bit set) (or un (vt102-escape "4m")) (setq un t) (Rtyo (- (CtoI ch) 400))))) (explodec string)) (and un (vt102-escape "m")))))) ;;; Home cursor to upper left corner. (defun DCTL-home-cursor () (setq X 0 Y 0) (vt102-escape H)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (vt102-escape J)) ;;; Clear to end of line. (defun DCTL-kill-line () (vt102-escape K)) ;;; Define the bounds of the scroll region. Relative cursor ;;; movement can only be done within this region. (defun DCTL-define-scroll-region (top bottom) (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom))) (t (setq scroll-region-top top scroll-region-bottom bottom) (Rtyo 33) (Rprinc "7") ;push cursor position (Rtyo 33) (Rprinc "[") ;redefine scroll region (homes) (cond ((not (= top 0)) (DCTL-outdec (1+ top)))) (cond ((not (= bottom (1- screenheight))) (Rprinc ";") (DCTL-outdec (1+ bottom)))) (Rprinc "r") (Rtyo 33) (Rprinc "8") ;pop cursor position (DCTL-pad 5.)))) ;;; Insert n lines at the current cursor position (defun DCTL-insert-lines (n) (do-times n (vt102-escape "L"))) ;;; Delete n lines at the current cursor position (defun DCTL-delete-lines (n) (do-times n (vt102-escape "M"))) ;;; Move text in scroll region up n lines (inserts whitespace at bottom) (defun DCTL-scroll-up-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (let ((oldy Y)) (Rtyo 33) (Rprinc "7") ;save cursor position (DCTL-position-cursor 0 bottom) (do-times nlines (Rtyo 12) (DCTL-pad 5.)) (Rtyo 33) (Rprinc "8") (setq Y oldy))) ;;; Move text in scroll region down n lines (inserts whitespace at top) (defun DCTL-scroll-down-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (do-times nlines (Rtyo 33) (Rprinc "M") (DCTL-pad 5.))) ;;; Insert given text at the cursor (defun DCTL-insert-char-string (string) (vt102-escape) (DCTL-outdec (stringlength string)) (Rprinc "@") (DCTL-output-underlined-string string) (setq X (+ X (stringlength string)))) ;;; Delete N characters at the cursor (defun DCTL-delete-chars (n) (vt102-escape) (and (> n 1) (DCTL-outdec n)) (Rprinc "P"))) ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary (or (and (boundp 'DCTL-have-nonstandard-setmodes) DCTL-have-nonstandard-setmodes) (progn (putprop 'DCTL-standard-set-modes (get 'e_pl1_$set_emacs_tty_modes 'subr) 'subr) (setq DCTL-have-nonstandard-setmodes t))) (defun e_pl1_$set_emacs_tty_modes () (DCTL-standard-set-modes) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) (setq DCTL-oflow-enabled nil) ;above gets called once before DCTL-init ;;; Load in special key definitions for VT1XX terminals (cond ((status feature Emacs) ;but only in Emacs (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))  video_system.ctl.lisp 08/20/86 2312.9rew 08/20/86 2256.4 62370 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1981 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; Video System CTL uses Multics Video System ;;; HISTORY COMMENTS: ;;; 1) change(83-12-03,Margolin), approve(), audit(), ;;; install(86-08-20,MR12.0-1136): ;;; pre-hcom history: ;;; Ripped off from VIP7200ctl BSG 6/6/78 (!) ;;; Suzanne Krupp 12/30/80 ;;; Standardized to not force vs on, 22 June 1981 RMSoley ;;; Protcol for window status BIM July 1981 ;;; Modified to check actual terminal capabilities before setting ;;; the flags by WMY, 11 August 1981 ;;; Add DCTL-prologue, which recomputes the window/terminal ;;; info. Barmar, 3 December 1983 ;;; 2) change(85-01-25,Margolin), approve(86-02-24,MCR7186), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Fix code declaration in video_system_ctl_util_$get_terminal_capabilities ;;; to have decimal point. ;;; END HISTORY COMMENTS (declare (special X Y tty-type rdis-whitespace-optimize idel-lines-availablep idel-chars-availablep DCTL-prologue-availablep DCTL-epilogue-availablep iocb_ptr code columns rows lines_per_scroll y_origin x_origin screenlinelen screenheight region-scroll-availablep overstrike-availablep ospeed) (*expr convert_status_code_ e_lap_$rtrim error_table_ Rprinc e_pl1_$get_iocb) (defpl1 window_$position_cursor "" (ptr) (fixed bin) (fixed bin) (return (setq code) fixed bin(35.))) (defpl1 window_$clear_to_end_of_window "" (ptr) (return (setq code) fixed bin(35.))) (defpl1 window_$clear_to_end_of_line "" (ptr) (return (setq code) fixed bin(35.))) (defpl1 window_$scroll_region "" (ptr) (fixed bin) (fixed bin) (fixed bin) (return (setq code) fixed bin(35.))) (defpl1 window_$insert_text "" (ptr) (char(*)) (return (setq code) fixed bin(35.))) (defpl1 window_$overwrite_text "" (ptr) (char(*)) (return (setq code) fixed bin(35.))) (defpl1 window_$delete_chars "" (ptr) (fixed bin) (return (setq code) fixed bin(35.))) (defpl1 window_$clear_window "" (ptr) (return (setq code) fixed bin(35.))) (defpl1 window_$bell "" (ptr) (return (setq code) fixed bin (35.))) ;;; Perform primitive window status check. to be haired up later. (defpl1 e_pl1_$check_for_window_status "" (fixed bin (35.))) ;;; This pl1 subroutine returns information about available terminal features. (defpl1 video_system_ctl_util_$get_terminal_capabilities "" (ptr) ; iocb pointer (lisp) ; the constant "t" (lisp) ; the constant "nil" (return (setq region-scroll-availablep) lisp) (return (setq idel-chars-availablep) lisp) (return (setq overstrike-availablep) lisp) (return (setq ospeed) fixed bin) (return (setq code) fixed bin(35.))) ;;; This pl1 routine returns infomation about the position and size of the ;;; window whose iocb pointer is iocb_ptr. (defpl1 video_system_ctl_util_$get_window_info "" (ptr) ; iocb_ptr (return (setq y_origin) fixed bin) ; Y_origin - line (return (setq x_origin) fixed bin) ; X_origin - col (return (setq screenlinelen) fixed bin) ; width (return (setq screenheight) fixed bin) ; height (return (setq code) fixed bin(35.))) ) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq iocb_ptr (e_pl1_$get_iocb)) (putprop 'video_system t 'tintinnabulum-ipsum-meum-sono) (setq tty-type 'video_system DCTL-prologue-availablep t DCTL-epilogue-availablep t) (DCTL-prologue) ;initialize window/terminal info (window_$clear_window iocb_ptr) (e_pl1_$check_for_window_status code) (setq X 0 Y 0 ;; rdis-whitespace-optimize nil ;; removed 12/3/83 )) ;;; Prologue code (defun DCTL-prologue () (video_system_ctl_util_$get_window_info iocb_ptr) (cond ((zerop code)) ((= code (error_table_ 'undefined_order_request)) ;not in video (Rprinc "emacs: Video system CTL invoked with no video system.")) (t (Rprinc (catenate "emacs: " (e_lap_$rtrim (cadr (convert_status_code_ code))) " Can't get window info.")))) (video_system_ctl_util_$get_terminal_capabilities iocb_ptr t nil) (cond ((not (zerop code)) (Rprinc (catenate "emacs: " (e_lap_$rtrim (cadr (convert_status_code_ code))) " Can't get terminal capabilities."))))) ;;; Epilogue code (defun DCTL-epilogue () (window_$clear_window iocb_ptr) (e_pl1_$check_for_window_status code)) ;;; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (window_$position_cursor iocb_ptr (1+ y) (1+ x)) (e_pl1_$check_for_window_status code) (setq X x Y y)) ;;; Output string. (defun DCTL-display-char-string (string) (window_$overwrite_text iocb_ptr string) (e_pl1_$check_for_window_status code) (setq X (+ X (stringlength string)))) ;;; Clear entire screen (defun DCTL-clear-screen () (window_$clear_window iocb_ptr) (e_pl1_$check_for_window_status code)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (window_$clear_to_end_of_window iocb_ptr) (e_pl1_$check_for_window_status code)) ;;; Clear to end of line. (defun DCTL-kill-line () (window_$clear_to_end_of_line iocb_ptr) (e_pl1_$check_for_window_status code)) ;;; Scroll down. (defun DCTL-scroll-down-region (nlines bottom) (window_$scroll_region iocb_ptr (1+ Y) (1+ (- bottom Y)) nlines) (e_pl1_$check_for_window_status code)) ;;; Scroll up. (defun DCTL-scroll-up-region (nlines bottom) (window_$scroll_region iocb_ptr (1+ Y) (1+ (- bottom Y)) (- nlines)) (e_pl1_$check_for_window_status code)) ;;; Insert a string of characters on the screen. (defun DCTL-insert-char-string (str) (window_$insert_text iocb_ptr str) (e_pl1_$check_for_window_status code) (setq X (+ X (stringlength str)))) ;;; Delete a string of characters from the screen. (defun DCTL-delete-chars (n) (window_$delete_chars iocb_ptr n) (e_pl1_$check_for_window_status code)) ;;; Ring the terminal's bell. (defun DCTL-ring-tty-bell () (window_$bell iocb_ptr) (e_pl1_$check_for_window_status code))  video_system_ctl_util_.pl1 11/15/84 1155.9rew 11/15/84 0849.0 31851 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1981 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* PL/1 utilities for the Emacs video_system terminal controller. Cleaned up and installed June 1981 Richard Mark Soley Modified 810811 by William M. York to add get_terminal_capabilities entry so video_system ctl can set flags properly. Modified 3 June 1982 by B Margolin to subtract one from width (for end-of-line cursor positioning) and to divide line_speed by 10 when setting ospeed. Modified 3 December 1983 by B. Margolin to fix get_terminal_capabilities and get_window_info to check codes before using the returned info (prevents arithmetic faults). Modified 2 November 1984 by B. Margolin to make $get_window_info return the correct starting column, even though video_system.ctl doesn't actually care about that parameter. */ video_system_ctl_util_: procedure (); return; /* Dummy */ /* System Entries */ dcl iox_$control entry(ptr, char(*), ptr, fixed bin(35)); /* Automatic */ dcl code fixed bin(35); dcl iocb_ptr ptr; dcl 1 WPI aligned like window_position_info; dcl 1 capabilities like capabilities_info; /* Builtin */ dcl (addr, divide) builtin; /* Parameters */ dcl (P_line, P_col, P_width, P_height) fixed bin parameter; dcl (P_constant_t, P_constant_nil) fixed bin(71) parameter; dcl (P_scroll_region_availablep, P_idel_chars_availablep, P_overstrike_availablep) fixed bin(71) parameter; dcl P_line_speed fixed bin parameter; dcl P_code fixed bin(35) parameter; dcl P_iocb_ptr ptr parameter; /* Include Files */ %include window_control_info; %include terminal_capabilities; get_window_info: entry(P_iocb_ptr, P_line, P_col, P_width, P_height, P_code); WPI.version = window_position_info_version_1; call iox_$control (P_iocb_ptr, "get_window_info", addr (WPI), code); if code = 0 then do; P_line = WPI.line; P_col = WPI.column; P_width = WPI.width - 1; /* Leave an extra column */ P_height = WPI.height; end; P_code = code; return; get_terminal_capabilities: entry (P_iocb_ptr, P_constant_t, P_constant_nil, P_scroll_region_availablep, P_idel_chars_availablep, P_overstrike_availablep, P_line_speed, P_code); /* This subroutine is called from Lisp with the symbols "t" and "nil" so it can return Lisp logical values without having to call into the Lisp world to get their values. */ capabilities.version = capabilities_info_version_1; call iox_$control (P_iocb_ptr, "get_capabilities", addr (capabilities), P_code); if P_code = 0 then do; if capabilities.flags.scroll_region then P_scroll_region_availablep = P_constant_t; else P_scroll_region_availablep = P_constant_nil; if (capabilities.flags.insert_chars & capabilities.flags.delete_chars) then P_idel_chars_availablep = P_constant_t; else P_idel_chars_availablep = P_constant_nil; if capabilities.flags.overprint then P_overstrike_availablep = P_constant_t; else P_overstrike_availablep = P_constant_nil; P_line_speed = divide (capabilities.line_speed, 10, 17, 0); end; return; end video_system_ctl_util_;  vip7200.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 20259 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; HISI VIP7200 control package ;;; Ripped off from vt52ctl BSG 3/9/78 ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'vip7200) (Rtyo 33)(Rprinc "H")(Rtyo 33)(Rprinc "J") (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 33)(Rprinc "D")))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "B"))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "f")(Rtyo (+ 40 x))(Rtyo (+ 40 y)) ))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "J") (Rtyo 0)) ;needed only at 9.6kb ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K"))  vip7201.ctl.lisp 08/20/86 2312.9rew 08/20/86 2306.3 26163 ;;; -*-LISP-*- ;;; ;;; HISI VIP7201 control package ;;; Ripped off from VIP7800ctl MBA 82-6-3 (!) ;;; (%include e-macros) (declare (special X Y ospeed screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-insert-mode-on)) (declare (*expr Rprinc Rtyo)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-chars-availablep t idel-lines-availablep (not (> ospeed 240.))) ; painfully slow idel-lines (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'vip7201) (setq X 0 Y 0) (DCTL-prologue) ) ;;; Prologue code (defun DCTL-prologue () (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "`")) ;;; Epilogue code (defun DCTL-epilogue () (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "`")) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 33)(Rprinc "D")))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "B"))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "f")(Rtyo (+ 40 x))(Rtyo (+ 40 y)) ))) ;;; Output string. (defun DCTL-display-char-string (string) ((lambda (strx) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "[J"))) (Rprinc string) (setq X (+ X strx))))) (stringlength string))) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "J") (Rtyo 0)) ;needed only at 9.6kb ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K")) (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "[L"))) (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "[M"))) (defun DCTL-insert-char-string (str) (cond (DCTL-insert-mode-on) (t (setq DCTL-insert-mode-on t) (Rtyo 33) (Rprinc "[I"))) (Rprinc str) (setq X (+ X (stringlength str)))) (defun DCTL-delete-chars (n) (do i 0 (1+ i)(= i n) (Rtyo 33)(Rprinc "[P")))  vip7800.ctl.lisp 11/15/84 1155.9rew 11/15/84 0849.6 32580 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; HISI VIP7800 control package ;;; Ripped off from VIP7200ctl BSG 6/6/78 (!) ;;; Modified 08/21/79 by GMP to optimize use of INSERT mode ;;; Modified 1/19/84 by Barmar to use Data-Space-Home instead ;;; of CUrsor-Home, so it works with the 72-line option. ;;; (declare (special X Y screenheight screenlinelen tty-type)) (declare (special idel-lines-availablep idel-chars-availablep)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-insert-mode-on)) (declare (*expr Rprinc Rtyo)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep t idel-chars-availablep t) (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'vip7800) (Rtyo 33)(Rprinc "[H")(Rtyo 33)(Rprinc "J") (setq X 0 Y 0) (DCTL-prologue)) ;;; Prologue code (defun DCTL-prologue () (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "[J")) ;;; Epilogue code (defun DCTL-epilogue () (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "[J")) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "[H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 33)(Rprinc "D")))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "B"))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "f")(Rtyo (+ 40 x))(Rtyo (+ 40 y)) ))) ;;; Output string. (defun DCTL-display-char-string (string) ((lambda (strx) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil) (Rtyo 33) (Rprinc "[J"))) (Rprinc string) (setq X (+ X strx))))) (stringlength string))) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "J") (Rtyo 0)) ;needed only at 9.6kb ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K")) (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "[L"))) (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "[M"))) (defun DCTL-insert-char-string (str) (cond (DCTL-insert-mode-on) (t (setq DCTL-insert-mode-on t) (Rtyo 33) (Rprinc "[I"))) (Rprinc str) (setq X (+ X (stringlength str)))) (defun DCTL-delete-chars (n) (do i 0 (1+ i)(= i n) (Rtyo 33)(Rprinc "[P")))  vis200.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 42831 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; *********************************************************** ;;;-------------------------------------------------------------------- ;;; ;;; This is the source to the VISUAL-200 terminal controller. ;;; The suggested name for it is vis200.ctl.lisp. Do what you ;;; wish with it. ;;; ;;;-------------------------------------------------------------------- ;;; ;;; Visual 200 control package ;;; 14 July 1982 ;;; Ripped off from various places by David M. Warme (Warme.FSOEP) ;;; (declare (special X Y screenheight tty-type ospeed)) (declare (special screenlinelen)) (declare (special idel-chars-availablep idel-lines-availablep tty-no-cleolp)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq screenheight 24.) ; 20 lines for editing (setq screenlinelen 79.) (setq tty-type 'vis200) (setq idel-lines-availablep t idel-chars-availablep t tty-no-cleolp nil) (Rtyo 27.) (Rprinc "v") ; clear screen (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (prog (ycost ; cost of y and x relative xcost ; movement what ; which movement is best cost) ; cost of that movement (and (= x X)(= y Y) ; return right away if already (return nil)) ; at desired position (setq what 1 ; 1: "home and relative move" cost (+ 2 y x x)) ; cost is V + 2*H + 2 (and (> cost 4) ; direct cursor address better? (setq what 0 ; 0: "direct cursor address" cost 4)) ; cost is 4 characters (setq ycost (cond ((< y Y) (- Y y)) (t (lsh (- y Y) 1)))) (setq xcost (cond ((> x X) (- x X)) (t (lsh (- X x) 1)))) (and (< (+ ycost xcost) cost) (setq what 3 ; 3: "relative move" cost (+ ycost xcost))) (and (< (+ 1 ycost x) cost) (setq what 2)) ; 2: "CR and relative move" (cond ((= what 0) ; Direct Cursor Address (Rtyo 27.) (Rprinc "Y") (Rtyo (+ 40 y)) (Rtyo (+ 40 x)) (setq X x Y y) (return nil)) ((= what 1) ; home and relative move? (Rtyo 27.) (Rprinc "H") ; home (setq X 0 Y 0)) ; keep track of cursor ; fall through to relative move ((= what 2) ; CR and relative move? (Rtyo 15) ; CR (setq X 0))) ; keep track of cursor ; fall through to relative move ; Relative Move (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 27.)(Rprinc "C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 10)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 12))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 27.)(Rprinc "A")))) (setq X x Y y) (return nil))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 27.)(Rprinc "y")(setq X 0 Y 0)) ; Insert chars. (defun DCTL-insert-char-string (str) (Rtyo 27.)(Rprinc "i") (Rprinc str) (Rtyo 27.)(Rprinc "j") (setq X (+ X (stringlength str)))) ; delete characters from current position in line. (defun DCTL-delete-chars (n) (do i 1 (1+ i) (> i n) (Rtyo 27.)(Rprinc "O"))) ; Insert blank lines at current position. (defun DCTL-insert-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 27.)(Rprinc "L"))) ; Delete lines at current position. (defun DCTL-delete-lines (n) (do i 1 (1+ i)(> i n) (Rtyo 33)(Rprinc "M"))) ; Send pad characters to wait specified no. of msecs. (defun DCTL-pad (n) (do i (// (* n ospeed) 100000.) (1- i) (= i 0) (Rtyo 0))) ; Clear to end of line. (defun DCTL-kill-line() (Rtyo 27.)(Rprinc "x"))  vistar.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 17820 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; VISTAR control package ;;; BSG 3/21/78 from DD4000ctl ;;; (declare (special X Y screenheight screenlinelen)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'vistar) (setq X 0 Y 0) (Rtyo 14)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 32) (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 31))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 010)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 35))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 34)))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 27)(Rtyo x)(Rtyo y)))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 14)) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 13))  vt100.ctl.lisp 08/20/86 2312.9rew 08/20/86 2306.0 85194 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; VT-100 control package ;;; CWH 3/17/79 ;;; Hacked for 3/31/79 redisplay on that day by BSG. ;;; Modified 06/01/79 by GMP to use paddings specified in VT100 manual ;;; with modifications as specified by CBF, and to make resetting of ;;; terminal attributes work. ;;; Modified 06/18/79 by GMP to reduce padding on scrolling. ;;; Modified 06/20/79 by GMP to fix minor bugs and use new ;;; epilogue/prologue mechanism. ;;; Modified 06/30/79 by GMP to fix bug in DCTL-outdec that caused ;;; failures when in 132 column mode ;;; Modified 08/14/79 by GMP to turn off smooth scroll on entrace ;;; and reduce padding requirements accordingly ;;; Modified 26 September 1980 by GMP to pad at 4800-baud ;;; Modified: 11 March 1981 by G. Palter for new terminal types and to ;;; support flow control ;;; Modified August 1982 by C. Hornig for underlining. ;;; Modified October 1982 by B. Margolin slight underlining change (%include e-macros) (declare (*expr Rprinc Rtyo DCTL-standard-set-modes)) (declare (special X Y screenheight screenlinelen ospeed given-tty-type)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-underline-mask)) (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom)) (declare (special DCTL-oflow-enabled DCTL-have-nonstandard-setmodes)) (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned))) (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow "")) ;;; Macro to output escape sequence (defun vt100-escape macro (form) (list 'Rprinc (apply 'catenate (cons (ItoC 33) (cons "[" (cdr form)))))) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 ((lambda (have-output) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi))))) nil)) ;;; Output padding, based on n pad characters at 9600-baud ;;; (Padding is sent only if flow control is disabled and the line speed is ;;; at least 4800 baud) (defun DCTL-pad (n) (or DCTL-oflow-enabled ;flow control should do it (< ospeed 480.) ;terminal not running hard (do-times (// (* n ospeed) 960.) (Rtyo 0)))) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq DCTL-underline-mask t) (setq idel-lines-availablep t idel-chars-availablep nil) (setq region-scroll-availablep t) (setq screenheight (or (cdr (assq given-tty-type '((vt100 . 24.) (vt100fc . 24.) (vt100ws . 14.) (vt100w . 24.) (vt100wfc . 24.)))) 24.)) ;default to 24 high (setq screenlinelen (or (cdr (assq given-tty-type '((vt100 . 79.) (vt100fc . 79.) (vt100ws . 131.) (vt100w . 131.) (vt100wfc . 131.)))) 79.)) ;default to 80 wide (setq DCTL-oflow-enabled (memq given-tty-type '(vt100fc vt100wfc))) (setq tty-type 'vt100) (DCTL-prologue) (DCTL-home-cursor) (DCTL-clear-rest-of-screen)) ;;; Initialization that must also be done after a QUIT (defun DCTL-prologue () (Rtyo 33) (Rprinc "<") (DCTL-pad 20.) ;set ANSI mode from VT52 mode (vt100-escape "?4l") ;reset scroll mode (jump) (vt100-escape "?6l") ;reset absolute origin mode (vt100-escape "r") ;reset scroll region (setq scroll-region-top 0 scroll-region-bottom (1- screenheight)) (vt100-escape "20l") ;turn off auto-CRLF (cond ((= screenlinelen 131.) ;set proper screen width (vt100-escape "?3h") (DCTL-pad 122.)) (t (vt100-escape "?3l") (DCTL-pad 122.))) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) ;;; Restore terminal to outside state (defun DCTL-epilogue () (vt100-escape "r")) ;reset scroll region ;;; Move terminal's cursor to desired position. ;;; Relative cursor movement commands are confined to the current scrolling ;;; region. Absolute movement commands can address the entire screen if ;;; if Origin Mode is reset. Missing arguments in the absolute positioning ;;; command default to one. Relative commands can be used if the scroll ;;; boundaries are examined. (defun DCTL-position-cursor (x y) (let ((deltax (- x X)) (deltay (- y Y))) (cond ((= deltay 0) (cond ((= deltax 0) nil) ((> deltax 0) ;move right (vt100-escape) (if (not (= deltax 1)) (DCTL-outdec deltax)) (Rprinc "C")) (t (cond ((= x 0) (Rtyo 15)) ;move left ((< (- deltax) 4) (do-times (- deltax) (Rtyo 10))) (t (vt100-escape) (DCTL-outdec (- deltax)) (Rprinc "D")))))) ((= deltax 0) ;;make sure scroll region doesn't screw us. (cond ((or (and (> y scroll-region-bottom) (not (> Y scroll-region-bottom))) (and (< y scroll-region-top) (not (< Y scroll-region-top)))) (vt100-absolute-position x y)) ((> deltay 0) ;move down (cond ((< deltay 4) (do-times deltay (Rtyo 12))) (t (vt100-escape) (DCTL-outdec deltay) (Rprinc "B")))) (t (cond ((= deltay -1) ;move up (Rtyo 33) (Rprinc "M")) (t (vt100-escape) (DCTL-outdec (- deltay)) (Rprinc "A")))))) (t (vt100-absolute-position x y))) (setq X x Y y))) ;;; Perform absolute cursor positioning (defun vt100-absolute-position (x y) (vt100-escape) (if (not (= y 0)) (DCTL-outdec (1+ y))) (if (not (= x 0)) (Rprinc ";") (DCTL-outdec (1+ x))) (Rprinc "H")) ;;; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (cond ((= 0 (not_ascii_ string)) ;optimize normal string (Rprinc string)) (t (let ((un nil)) (mapc '(lambda (ch) (cond ((< (CtoI ch) 400) (and un (vt100-escape "m")) (setq un nil) (Rprinc ch)) (t ;underlined character (or un (vt100-escape "4m")) (setq un t) (Rtyo (- (CtoI ch) 400))))) (explodec string)) (and un (vt100-escape "m")))))) ;;; Home cursor to upper left corner. (defun DCTL-home-cursor () (setq X 0 Y 0) (vt100-escape H)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (vt100-escape J) (DCTL-pad 45.)) ;;; Clear to end of line. (defun DCTL-kill-line () (vt100-escape K) (DCTL-pad 2)) ;;; Define the bounds of the scroll region. Relative cursor ;;; movement can only be done within this region. (defun DCTL-define-scroll-region (top bottom) (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom))) (t (setq scroll-region-top top scroll-region-bottom bottom) (Rtyo 33) (Rprinc "7") ;push cursor position (Rtyo 33) (Rprinc "[") ;redefine scroll region (homes) (cond ((not (= top 0)) (DCTL-outdec (1+ top)))) (cond ((not (= bottom (1- screenheight))) (Rprinc ";") (DCTL-outdec (1+ bottom)))) (Rprinc "r") (Rtyo 33) (Rprinc "8")))) ;pop cursor position ;;; Insert n lines at the current cursor position (defun DCTL-insert-lines (n) (DCTL-scroll-down-region n (1- screenheight))) ;;; Delete n lines at the current cursor position (defun DCTL-delete-lines (n) (DCTL-scroll-up-region n (1- screenheight))) ;;; Move text in scroll region up n lines (inserts whitespace at bottom) (defun DCTL-scroll-up-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (let ((oldy Y)) (Rtyo 33) (Rprinc "7") ;save cursor position (DCTL-position-cursor 0 bottom) (do-times nlines (Rtyo 12) (DCTL-pad 30.)) (Rtyo 33) (Rprinc "8") (setq Y oldy))) ;;; Move text in scroll region down n lines (inserts whitespace at top) (defun DCTL-scroll-down-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (do-times nlines (Rtyo 33) (Rprinc 'M) (DCTL-pad 30.))) ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary (or (and (boundp 'DCTL-have-nonstandard-setmodes) DCTL-have-nonstandard-setmodes) (progn (putprop 'DCTL-standard-set-modes (get 'e_pl1_$set_emacs_tty_modes 'subr) 'subr) (setq DCTL-have-nonstandard-setmodes t))) (defun e_pl1_$set_emacs_tty_modes () (DCTL-standard-set-modes) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) (setq DCTL-oflow-enabled nil) ;above gets called once before DCTL-init ;;; Load in special key definitions for VT1XX terminals (cond ((status feature Emacs) ;but only in Emacs (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))  vt102.ctl.lisp 08/20/86 2312.9rew 08/20/86 2306.3 85824 ;;; ****************************************************** ;;; * * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; * * ;;; ****************************************************** ;;; ;;; ;;; VT102 control package ;;; Created: 20 May 1983 by B. Margolin from VT132 CTL ;;; Modified: 2 November 1984 by B. Margolin to remove unexecuted ;;; forms from DCTL-clear-rest-of-screen and DCTL-kill-line. ;;; (%include e-macros) (declare (*expr Rprinc Rtyo DCTL-standard-set-modes)) (declare (special X Y screenheight screenlinelen ospeed given-tty-type)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-underline-mask)) (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom DCTL-insert-mode-on)) (declare (special DCTL-oflow-enabled DCTL-have-nonstandard-setmodes)) (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned))) (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow "")) ;;; Macro to output escape sequence (defun vt102-escape macro (form) (list 'Rprinc (apply 'catenate (cons (ItoC 33) (cons "[" (cdr form)))))) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 (let ((have-output)) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi)))))) ;;; Output padding, based on n pad characters at 9600-baud (defun DCTL-pad (n) (or DCTL-oflow-enabled ;flow control should do it (do-times (// (* n ospeed) 960.) (Rtyo 0)))) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq DCTL-underline-mask t) (setq idel-lines-availablep t idel-chars-availablep t) (setq region-scroll-availablep t) (setq screenheight 24.) (setq screenlinelen (or (cdr (assq given-tty-type '((vt102 . 79.) (vt102_oflow . 79.) (vt102_80c . 79.) (vt102_80c_oflow . 79.) (vt102_132c . 131.) (vt102_132c_oflow . 131.)))) 131.)) ;default to 132 wide (setq DCTL-oflow-enabled (memq given-tty-type '(vt102_oflow vt102_80c_oflow vt102_132c_oflow))) (setq tty-type 'vt102) (DCTL-prologue) (DCTL-home-cursor) (DCTL-clear-rest-of-screen)) ;;; Initialization that must also be done after a QUIT (defun DCTL-prologue () (Rtyo 33) (Rprinc "<") ;set ANSI mode from VT52 mode (vt102-escape "?4l") ;reset scroll mode (jump) (vt102-escape "?6l") ;reset absolute origin mode (vt102-escape "r") ;reset scroll region (vt102-escape "4l") ;reset insert mode (vt102-escape "20l") ;turn off auto-CRLF (cond ((= screenlinelen 131.) ;set proper screen width (vt102-escape "?3h")) (t (vt102-escape "?3l"))) (DCTL-pad 102.) (setq scroll-region-top 0 scroll-region-bottom (1- screenheight)) (setq DCTL-insert-mode-on nil) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) ;;; Restore terminal to outside state (defun DCTL-epilogue () (vt102-escape "r") ;reset scroll region (vt102-escape "4l") ;reset insert mode (DCTL-pad 4) (setq DCTL-insert-mode-on nil)) ;;; Move terminal's cursor to desired position. ;;; Relative cursor movement commands are confined to the current scrolling region. Absolute movement commands can ;;; address the entire screen if if Origin Mode is reset. Missing arguments in the absolute positioning command default ;;; to one. Relative commands can be used if the scroll boundaries are examined. (defun DCTL-position-cursor (x y) (let ((deltax (- x X)) (deltay (- y Y))) (cond ((= deltay 0) (cond ((= deltax 0) nil) ((> deltax 0) ;move right (vt102-escape) (if (not (= deltax 1)) (DCTL-outdec deltax)) (Rprinc "C")) (t (cond ((= x 0) (Rtyo 15) (DCTL-pad (1+ (// X 4)))) ;move left ((< (- deltax) 4) (do-times (- deltax) (Rtyo 10))) (t (vt102-escape) (DCTL-outdec (- deltax)) (Rprinc "D")))))) ((= deltax 0) ;;make sure scroll region doesn't screw us. (cond ((or (and (> y scroll-region-bottom) (not (> Y scroll-region-bottom))) (and (< y scroll-region-top) (not (< Y scroll-region-top)))) (vt102-absolute-position x y)) ((> deltay 0) ;move down (cond ((< deltay 4) (do-times deltay (Rtyo 12))) (t (vt102-escape) (DCTL-outdec deltay) (Rprinc "B")))) (t (cond ((= deltay -1) ;move up (Rtyo 33) (Rprinc "M")) (t (vt102-escape) (DCTL-outdec (- deltay)) (Rprinc "A")))))) (t (vt102-absolute-position x y))) (setq X x Y y))) ;;; Perform absolute cursor positioning (defun vt102-absolute-position (x y) (vt102-escape) (if (not (= y 0)) (DCTL-outdec (1+ y))) (if (not (= x 0)) (Rprinc ";") (DCTL-outdec (1+ x))) (Rprinc "H")) ;;; Output string. (defun DCTL-display-char-string (string) (let ((strx (stringlength string))) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil) (vt102-escape "4l") (DCTL-pad 1.))) ;reset insert mode (DCTL-output-underlined-string string) (setq X (+ X strx)))))) (defun DCTL-output-underlined-string (string) (cond ((zerop (not_ascii_ string)) ;optimize standard string (Rprinc string)) (t (let ((un nil)) (mapc '(lambda (ch) (cond ((< (CtoI ch) 400) ;normal char (and un (vt102-escape "m")) ;out of underline mode (setq un nil) (Rprinc ch)) (t ;underlined char (400-bit set) (or un (vt102-escape "4m")) (setq un t) (Rtyo (- (CtoI ch) 400))))) (explodec string)) (and un (vt102-escape "m")))))) ;;; Home cursor to upper left corner. (defun DCTL-home-cursor () (setq X 0 Y 0) (vt102-escape H)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (vt102-escape J)) ;;; Clear to end of line. (defun DCTL-kill-line () (vt102-escape K)) ;;; Define the bounds of the scroll region. Relative cursor ;;; movement can only be done within this region. (defun DCTL-define-scroll-region (top bottom) (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom))) (t (setq scroll-region-top top scroll-region-bottom bottom) (Rtyo 33) (Rprinc "7") ;push cursor position (Rtyo 33) (Rprinc "[") ;redefine scroll region (homes) (cond ((not (= top 0)) (DCTL-outdec (1+ top)))) (cond ((not (= bottom (1- screenheight))) (Rprinc ";") (DCTL-outdec (1+ bottom)))) (Rprinc "r") (Rtyo 33) (Rprinc "8") ;pop cursor position (DCTL-pad 5.)))) ;;; Insert n lines at the current cursor position (defun DCTL-insert-lines (n) (DCTL-scroll-down-region n (1- screenheight))) ;;; Delete n lines at the current cursor position (defun DCTL-delete-lines (n) (DCTL-scroll-up-region n (1- screenheight))) ;;; Move text in scroll region up n lines (inserts whitespace at bottom) (defun DCTL-scroll-up-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (let ((oldy Y)) (Rtyo 33) (Rprinc "7") ;save cursor position (DCTL-position-cursor 0 bottom) (do-times nlines (Rtyo 12) (DCTL-pad 100.)) (Rtyo 33) (Rprinc "8") (setq Y oldy))) ;;; Move text in scroll region down n lines (inserts whitespace at top) (defun DCTL-scroll-down-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (do-times nlines (Rtyo 33) (Rprinc 'M) (DCTL-pad 100.))) ;;; Insert the given text at the cursor (defun DCTL-insert-char-string (string) (cond (DCTL-insert-mode-on) (t (setq DCTL-insert-mode-on t) (vt102-escape "4h"))) ;turn on insert mode (DCTL-output-underlined-string string) (setq X (+ X (stringlength string))) (DCTL-pad (stringlength string))) ;;; Delete N characters at the cursor (defun DCTL-delete-chars (n) (vt102-escape) (and (> n 1) (DCTL-outdec n)) (Rprinc "P") (DCTL-pad n)) ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary (or (and (boundp 'DCTL-have-nonstandard-setmodes) DCTL-have-nonstandard-setmodes) (progn (putprop 'DCTL-standard-set-modes (get 'e_pl1_$set_emacs_tty_modes 'subr) 'subr) (setq DCTL-have-nonstandard-setmodes t))) (defun e_pl1_$set_emacs_tty_modes () (DCTL-standard-set-modes) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) (setq DCTL-oflow-enabled nil) ;above gets called once before DCTL-init ;;; Load in special key definitions for VT1XX terminals (cond ((status feature Emacs) ;but only in Emacs (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))  vt132.ctl.lisp 08/20/86 2312.9rew 08/20/86 2306.1 90099 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; VT132 control package ;;; Created: 24 April 1980 by G. Palter from VT132P CTL ;;; Modified: 11 March 1981 by G. Palter for new terminal types and to ;;; support flow control ;;; Modified: 20 August 1982 by B. Margolin to copy CAH's underlining ;;; code from vt100 CTL ;;; Modified: 12 October 1982 by B. Margolin for slight underline change ;;; (%include e-macros) (declare (*expr Rprinc Rtyo DCTL-standard-set-modes)) (declare (special X Y screenheight screenlinelen ospeed given-tty-type)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-underline-mask)) (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom DCTL-insert-mode-on)) (declare (special DCTL-oflow-enabled DCTL-have-nonstandard-setmodes)) (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned))) (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow "")) ;;; Macro to output escape sequence (defun vt132-escape macro (form) (list 'Rprinc (apply 'catenate (cons (ItoC 33) (cons "[" (cdr form)))))) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 (let ((have-output)) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi)))))) ;;; Output padding, based on n pad characters at 9600-baud ;;; (Padding is sent only if flow control is disabled and the line speed is ;;; at least 4800 baud) (defun DCTL-pad (n) (or DCTL-oflow-enabled ;flow control should do it (< ospeed 480.) ;terminal not running hard (do-times (// (* n ospeed) 960.) (Rtyo 0)))) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq DCTL-underline-mask t) (setq idel-lines-availablep t idel-chars-availablep t) (setq region-scroll-availablep t) (setq screenheight 24.) (setq screenlinelen (or (cdr (assq given-tty-type '((vt132 . 131.) (vt132_oflow . 131.) (vt132_80c . 79.) (vt132_80c_oflow . 79.)))) 131.)) ;default to 132 wide (setq DCTL-oflow-enabled (memq given-tty-type '(vt132_oflow vt132_80c_oflow))) (setq tty-type 'vt132) (DCTL-prologue) (DCTL-home-cursor) (DCTL-clear-rest-of-screen)) ;;; Initialization that must also be done after a QUIT (defun DCTL-prologue () (Rtyo 33) (Rprinc "<") (DCTL-pad 20.) ;set ANSI mode from VT52 mode (vt132-escape "?4l") ;reset scroll mode (jump) (vt132-escape "?6l") ;reset absolute origin mode (vt132-escape "r") ;reset scroll region (vt132-escape "4l") ;reset insert mode (vt132-escape "20l") ;turn off auto-CRLF (cond ((= screenlinelen 131.) ;set proper screen width (vt132-escape "?3h") (DCTL-pad 122.)) (t (vt132-escape "?3l") (DCTL-pad 122.))) (setq scroll-region-top 0 scroll-region-bottom (1- screenheight)) (setq DCTL-insert-mode-on nil) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) ;;; Restore terminal to outside state (defun DCTL-epilogue () (vt132-escape "r") ;reset scroll region (vt132-escape "4l") ;reset insert mode (setq DCTL-insert-mode-on nil)) ;;; Move terminal's cursor to desired position. ;;; Relative cursor movement commands are confined to the current scrolling region. Absolute movement commands can ;;; address the entire screen if if Origin Mode is reset. Missing arguments in the absolute positioning command default ;;; to one. Relative commands can be used if the scroll boundaries are examined. (defun DCTL-position-cursor (x y) (let ((deltax (- x X)) (deltay (- y Y))) (cond ((= deltay 0) (cond ((= deltax 0) nil) ((> deltax 0) ;move right (vt132-escape) (if (not (= deltax 1)) (DCTL-outdec deltax)) (Rprinc "C")) (t (cond ((= x 0) (Rtyo 15) (DCTL-pad (1+ (// X 4)))) ;move left ((< (- deltax) 4) (do-times (- deltax) (Rtyo 10))) (t (vt132-escape) (DCTL-outdec (- deltax)) (Rprinc "D")))))) ((= deltax 0) ;;make sure scroll region doesn't screw us. (cond ((or (and (> y scroll-region-bottom) (not (> Y scroll-region-bottom))) (and (< y scroll-region-top) (not (< Y scroll-region-top)))) (vt132-absolute-position x y)) ((> deltay 0) ;move down (cond ((< deltay 4) (do-times deltay (Rtyo 12))) (t (vt132-escape) (DCTL-outdec deltay) (Rprinc "B"))) (DCTL-pad (* 2 deltay))) (t (cond ((= deltay -1) ;move up (Rtyo 33) (Rprinc "M")) (t (vt132-escape) (DCTL-outdec (- deltay)) (Rprinc "A"))) (DCTL-pad (* 2 (1+ (- deltay))))))) (t (vt132-absolute-position x y))) (setq X x Y y))) ;;; Perform absolute cursor positioning (defun vt132-absolute-position (x y) (vt132-escape) (if (not (= y 0)) (DCTL-outdec (1+ y))) (if (not (= x 0)) (Rprinc ";") (DCTL-outdec (1+ x))) (Rprinc "H") (DCTL-pad (* 2 (+ (abs (- Y y)) (// (abs (- X x)) 4) 1)))) ;;; Output string. (defun DCTL-display-char-string (string) (let ((strx (stringlength string))) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil) (vt132-escape "4l") (DCTL-pad 10.))) ;reset insert mode (DCTL-output-underlined-string string) (setq X (+ X strx)))))) (defun DCTL-output-underlined-string (string) (cond ((zerop (not_ascii_ string)) ;optimize standard string (Rprinc string)) (t (let ((un nil)) (mapc '(lambda (ch) (cond ((< (CtoI ch) 400) ;normal char (and un (vt132-escape "m")) ;out of underline mode (setq un nil) (Rprinc ch)) (t ;underlined char (400-bit set) (or un (vt132-escape "4m")) (setq un t) (Rtyo (- (CtoI ch) 400))))) (explodec string)) (and un (vt132-escape "m")))))) ;;; Home cursor to upper left corner. (defun DCTL-home-cursor () (setq X 0 Y 0) (vt132-escape H) (DCTL-pad 10.)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (vt132-escape J) (DCTL-pad 60.)) ;;; Clear to end of line. (defun DCTL-kill-line () (vt132-escape K) (DCTL-pad 5)) ;;; Define the bounds of the scroll region. Relative cursor ;;; movement can only be done within this region. (defun DCTL-define-scroll-region (top bottom) (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom))) (t (setq scroll-region-top top scroll-region-bottom bottom) (Rtyo 33) (Rprinc "7") ;push cursor position (Rtyo 33) (Rprinc "[") ;redefine scroll region (homes) (cond ((not (= top 0)) (DCTL-outdec (1+ top)))) (cond ((not (= bottom (1- screenheight))) (Rprinc ";") (DCTL-outdec (1+ bottom)))) (Rprinc "r") (Rtyo 33) (Rprinc "8") (DCTL-pad 25.)))) ;pop cursor position ;;; Insert n lines at the current cursor position (defun DCTL-insert-lines (n) (DCTL-scroll-down-region n (1- screenheight))) ;;; Delete n lines at the current cursor position (defun DCTL-delete-lines (n) (DCTL-scroll-up-region n (1- screenheight))) ;;; Move text in scroll region up n lines (inserts whitespace at bottom) (defun DCTL-scroll-up-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (let ((oldy Y)) (Rtyo 33) (Rprinc "7") ;save cursor position (DCTL-position-cursor 0 bottom) (do-times nlines (Rtyo 12) (DCTL-pad 45.)) (Rtyo 33) (Rprinc "8") (setq Y oldy))) ;;; Move text in scroll region down n lines (inserts whitespace at top) (defun DCTL-scroll-down-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (do-times nlines (Rtyo 33) (Rprinc 'M) (DCTL-pad 45.))) ;;; Insert the given text at the cursor (defun DCTL-insert-char-string (string) (cond (DCTL-insert-mode-on) (t (setq DCTL-insert-mode-on t) (vt132-escape "4h"))) ;turn on insert mode (DCTL-output-underlined-string string) (setq X (+ X (stringlength string))) (DCTL-pad (max (* 2 (stringlength string)) (- screenlinelen X)))) ;;; Delete N characters at the cursor (defun DCTL-delete-chars (n) (vt132-escape) (and (> n 1) (DCTL-outdec n)) (Rprinc "P") (DCTL-pad (* 7 n))) ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary (or (and (boundp 'DCTL-have-nonstandard-setmodes) DCTL-have-nonstandard-setmodes) (progn (putprop 'DCTL-standard-set-modes (get 'e_pl1_$set_emacs_tty_modes 'subr) 'subr) (setq DCTL-have-nonstandard-setmodes t))) (defun e_pl1_$set_emacs_tty_modes () (DCTL-standard-set-modes) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) (setq DCTL-oflow-enabled nil) ;above gets called once before DCTL-init ;;; Load in special key definitions for VT1XX terminals (cond ((status feature Emacs) ;but only in Emacs (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))  vt132p.ctl.lisp 08/20/86 2312.9rew 08/20/86 2256.8 88947 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; ;;; VT132 prototype control package ;;; Created: 4 December 1979 by G. Palter from VT100 CTL ;;; Modified: 11 March 1981 by G. Palter for new terminal types and to ;;; support flow control ;;; HISTORY COMMENTS: ;;; 1) change(86-04-23,Margolin), approve(86-04-23,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added *expr declarations so that it would compile without warnings. ;;; END HISTORY COMMENTS ;;; ;;; ;;; Known mis-features in prototype VT132 terminal: ;;; o Insert mode doesn't turn on INSERT LED ;;; o In 132-column mode, insert mode does not work in columns 1, 2, and 3; overwrite occurs instead ;;; o All new VT132 only sequences use "l" to set and "h" to reset; this violates ANSI standard ;;; (%include e-macros) (declare (special X Y screenheight screenlinelen ospeed given-tty-type)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep)) (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom DCTL-insert-mode-on)) (declare (special DCTL-oflow-enabled)) (declare (array* (notype (screen ?)))) (declare (*expr DCTL-standard-set-modes Rprinc Rtyo)) (declare (defpl1 vt1xx_ctl_util_$re_enable_oflow "")) ;;; Macro to output escape sequence (defun vt132p-escape macro (form) (list 'Rprinc (apply 'catenate (cons (ItoC 33) (cons "[" (cdr form)))))) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 ((lambda (have-output) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi))))) nil)) ;;; Output padding (only at 9600 baud), based on n pad characters at 9600-baud (defun DCTL-pad (n) (and (= ospeed 960.) (DCTL-real-pad n))) ;;; Output padding if flow control off, based on n pad characters at 9600-baud (defun DCTL-real-pad (n) (or DCTL-oflow-enabled ;flow control should do it (do-times (// (* n ospeed) 960.) (Rtyo 0)))) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq idel-lines-availablep t idel-chars-availablep t) (setq region-scroll-availablep t) (setq screenheight 24.) (setq screenlinelen (or (cdr (assq given-tty-type '((vt132p . 131.) (vt132p_oflow . 131.) (vt132p_80c . 79.) (vt132p_80c_oflow . 79.)))) 131.)) ;default to 132 wide (setq DCTL-oflow-enabled (memq given-tty-type '(vt132p_oflow vt132p_80c_oflow))) (setq tty-type 'vt132p) (DCTL-prologue) (DCTL-home-cursor) (DCTL-clear-rest-of-screen)) ;;; Initialization that must also be done after a QUIT (defun DCTL-prologue () (Rtyo 33) (Rprinc "<") (DCTL-pad 20.) ;set ANSI mode from VT52 mode (vt132p-escape "?4l") ;reset scroll mode (jump) (vt132p-escape "?6l") ;reset absolute origin mode (vt132p-escape "r") ;reset scroll region (vt132p-escape "4h") (vt132p-escape "0q") ;reset insert mode (vt132p-escape "20l") ;turn off auto-CRLF (cond ((= screenlinelen 131.) ;set proper screen width (vt132p-escape "?3h") (DCTL-pad 122.)) (t (vt132p-escape "?3l") (DCTL-pad 122.))) (setq scroll-region-top 0 scroll-region-bottom (1- screenheight)) (setq DCTL-insert-mode-on nil) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) ;;; Restore terminal to outside state (defun DCTL-epilogue () (vt132p-escape "r") ;reset scroll region (vt132p-escape "4h") (vt132p-escape "0q") ;reset insert mode (setq DCTL-insert-mode-on nil)) ;;; Move terminal's cursor to desired position. ;;; Relative cursor movement commands are confined to the current scrolling ;;; region. Absolute movement commands can address the entire screen if ;;; if Origin Mode is reset. Missing arguments in the absolute positioning ;;; command default to one. Relative commands can be used if the scroll ;;; boundaries are examined. (defun DCTL-position-cursor (x y) (let ((deltax (- x X)) (deltay (- y Y))) (cond ((= deltay 0) (cond ((= deltax 0) nil) ((> deltax 0) ;move right (vt132p-escape) (if (not (= deltax 1)) (DCTL-outdec deltax)) (Rprinc "C")) (t (cond ((= x 0) (Rtyo 15)) ;move left ((< (- deltax) 4) (do-times (- deltax) (Rtyo 10))) (t (vt132p-escape) (DCTL-outdec (- deltax)) (Rprinc "D")))))) ((= deltax 0) ;;make sure scroll region doesn't screw us. (cond ((or (and (> y scroll-region-bottom) (not (> Y scroll-region-bottom))) (and (< y scroll-region-top) (not (< Y scroll-region-top)))) (vt132p-absolute-position x y)) ((> deltay 0) ;move down (cond ((< deltay 4) (do-times deltay (Rtyo 12))) (t (vt132p-escape) (DCTL-outdec deltay) (Rprinc "B")))) (t (cond ((= deltay -1) ;move up (Rtyo 33) (Rprinc "M")) (t (vt132p-escape) (DCTL-outdec (- deltay)) (Rprinc "A")))))) (t (vt132p-absolute-position x y))) (setq X x Y y))) ;;; Perform absolute cursor positioning (defun vt132p-absolute-position (x y) (vt132p-escape) (if (not (= y 0)) (DCTL-outdec (1+ y))) (if (not (= x 0)) (Rprinc ";") (DCTL-outdec (1+ x))) (Rprinc "H")) ;;; Output string. (defun DCTL-display-char-string (string) ((lambda (strx) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil) (vt132p-escape "4h") (vt132p-escape "0q"))) (Rprinc string) (setq X (+ X strx))))) (stringlength string))) ;;; Home cursor to upper left corner. (defun DCTL-home-cursor () (setq X 0 Y 0) (vt132p-escape H)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (vt132p-escape J) (DCTL-pad 45.)) ;;; Clear to end of line. (defun DCTL-kill-line () (vt132p-escape K) (DCTL-pad 2)) ;;; Define the bounds of the scroll region. Relative cursor ;;; movement can only be done within this region. (defun DCTL-define-scroll-region (top bottom) (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom))) (t (setq scroll-region-top top scroll-region-bottom bottom) (Rtyo 33) (Rprinc "7") ;push cursor position (Rtyo 33) (Rprinc "[") ;redefine scroll region (homes) (cond ((not (= top 0)) (DCTL-outdec (1+ top)))) (cond ((not (= bottom (1- screenheight))) (Rprinc ";") (DCTL-outdec (1+ bottom)))) (Rprinc "r") (Rtyo 33) (Rprinc "8")))) ;pop cursor position ;;; Insert n lines at the current cursor position (defun DCTL-insert-lines (n) (DCTL-scroll-down-region n (1- screenheight))) ;;; Delete n lines at the current cursor position (defun DCTL-delete-lines (n) (DCTL-scroll-up-region n (1- screenheight))) ;;; Move text in scroll region up n lines (inserts whitespace at bottom) (defun DCTL-scroll-up-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (let ((oldy Y)) (Rtyo 33) (Rprinc "7") ;save cursor position (DCTL-position-cursor 0 bottom) (do-times nlines (Rtyo 12) (DCTL-pad 30.)) (Rtyo 33) (Rprinc "8") (setq Y oldy))) ;;; Move text in scroll region down n lines (inserts whitespace at top) (defun DCTL-scroll-down-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (do-times nlines (Rtyo 33) (Rprinc 'M) (DCTL-pad 30.))) ;;; Insert the given text at the cursor (watching out for 132-column bug) (defun DCTL-insert-char-string (string) (cond (DCTL-insert-mode-on) (t (setq DCTL-insert-mode-on t) (vt132p-escape "4l") (vt132p-escape "3q"))) (cond ((or (> X 2) (= screenlinelen 79.)) ;new text is beyond column 3 or 80-column mode (Rprinc string)) (t ;columns 1,2, or 3: special case as they overwrite ((lambda (X extra) (Rprinc string) (Rprinc extra) (setq X (+ X (stringlength string) (stringlength extra))) (DCTL-position-cursor (- X (stringlength extra)) Y)) X ;must account for extra movement (substr (cadr (screen Y)) (1+ X) (- 3 X))))) (setq X (+ X (stringlength string)))) ;;; Delete N characters at the cursor (defun DCTL-delete-chars (n) (vt132p-escape) (and (> n 1) (DCTL-outdec n)) (Rprinc "P")) ;;; Replacement for e_pl1_$set_emacs_tty_modes that enables oflow if necessary (putprop 'DCTL-standard-set-modes (get 'e_pl1_$set_emacs_tty_modes 'subr) 'subr) (defun e_pl1_$set_emacs_tty_modes () (DCTL-standard-set-modes) (and DCTL-oflow-enabled (vt1xx_ctl_util_$re_enable_oflow))) (setq DCTL-oflow-enabled nil) ;above gets called once before DCTL-init ;;; Load in special key definitions for VT1XX terminals (cond ((status feature Emacs) ;but only in Emacs (load (list (car (namelist (truename infile))) "vt1xx_keys_"))))  vt1xx_ctl_util_.pl1 10/07/88 1209.8rew 10/07/88 1208.6 46296 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1978 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Utility package used by Emacs VT1XX terminal CTL packages */ /* Created: 11 March 1981 by G. Palter */ /****^ HISTORY COMMENTS: 1) change(88-08-14,GDixon), approve(88-09-20,MCR8002), audit(88-09-21,Blair), install(88-10-07,MR12.2-1141): Added $get_screen_size entrypoint for use in versaterm.ctl.lisp. END HISTORY COMMENTS */ vt1xx_ctl_util_: procedure (); return; /* not an entry */ dcl code fixed bin(35) auto; dcl tty_mode_string char(512); dcl (addr, null) builtin; dcl iox_$user_io pointer external; dcl e_pl1_$get_emacs_data_ptr entry() returns(ptr); dcl iox_$modes entry (pointer, character (*), character (*), fixed binary (35)); dcl mode_string_$get_mode entry (char(*), char(*), ptr, fixed bin(35)); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Enable output flow control: Emacs resets "oflow" mode; however, for certain VT1XX terminal types, the terminal is assumed to be running with XON/XOFF enabled. For these terminals, it is necessary to turn "oflow" mode back on */ re_enable_oflow: entry (); call iox_$modes (iox_$user_io, "oflow", (""), (0)); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* get_screen_size: */ /* This entrypoint is called by versaterm.ctl to extract the current line and page lengths from */ /* the command line values given in the emacs command, or else from the current values given in */ /* the tty_ mode string. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_screen_size: entry (P_ll, P_pl); dcl P_ll fixed bin parm; /* Screen line length. (Out) */ dcl P_pl fixed bin parm; /* Screen page length. (Out) */ dcl DEFAULT_LINE_LEN fixed bin int static options(constant) init(79); dcl DEFAULT_PAGE_LEN fixed bin int static options(constant) init(24); emacs_data_ptr = e_pl1_$get_emacs_data_ptr(); /* Get pointer to emacs command line args*/ if emacs_data_ptr = null then do; /* If not being called from emacs ctl, */ P_ll = DEFAULT_LINE_LEN; /* then give up and return default */ P_pl = DEFAULT_PAGE_LEN; /* values. */ end; else do; /* If being called from emacs ctl... */ if emacs_data.arguments.ll ^= -1 then /* User typed: emacs -ll NN */ P_ll = emacs_data.arguments.ll; /* so use the value he typed. */ else do; /* Otherwise, extract llNN mode from */ MV.version = mode_value_version_3; /* tty_ mode string and return that. */ tty_mode_string = emacs_data.tty_modes; call mode_string_$get_mode (tty_mode_string, "ll", addr(MV), code); if code ^= 0 then P_ll = DEFAULT_LINE_LEN; else do; if MV.flags.numeric_valuep then P_ll = MV.numeric_value; else P_ll = DEFAULT_LINE_LEN; end; end; if emacs_data.arguments.pl ^= -1 then /* User typed: emacs -pl NN */ P_pl = emacs_data.arguments.pl; /* so use the value he typed. */ else do; /* Otherwise, extract plNN mode from */ MV.version = mode_value_version_3; /* tty_ mode string and return that. */ tty_mode_string = emacs_data.tty_modes; call mode_string_$get_mode (tty_mode_string, "pl", addr(MV), code); if code ^= 0 then P_pl = DEFAULT_PAGE_LEN; else do; if MV.flags.numeric_valuep then P_pl = MV.numeric_value + 1; /* Add 1 to tty_ mode because tty_ */ else /* reduces actual screen size by 1 to */ P_pl = DEFAULT_PAGE_LEN; /* leave room for EOP prompt. Emacs */ end; /* doesn't need an EOP line so we can */ end; /* add back that line. */ end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ %include emacs_data; %include mode_string_info; dcl 1 MV aligned like mode_value auto; end vt1xx_ctl_util_;  vt1xx_keys_.lisp 08/20/86 2312.9rew 08/20/86 2243.0 66510 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; HISTORY COMMENTS: ;;; 1) change(86-04-23,Margolin), approve(86-04-23,MCR7325), ;;; audit(86-08-12,Harvey), install(86-08-20,MR12.0-1136): ;;; Added *expr declarations so that it would compile without warnings. ;;; END HISTORY COMMENTS ;;; ;;; Special key definitions for VT1XX terminals: control, meta, control-meta, ;;; and meta-control prefix functions ;;; Created: 11 March 1981 by G. Palter (%include e-macros) (declare (special last-command-triplet-mpfxk last-command-triplet-1)) (declare (array* (notype (key-bindings 128. 2)))) (declare (*expr execute-command last-command-triplet)) ;;; Called as part of function that reads a key name from the minibuffer (defun key-prompt-1 (metap key prefix) (prog (mf1) (and (or prefix (= metap 1)) (< key (1+ (CtoI "z")))(> key (1- (CtoI "a"))) (setq key (- key 40))) (setq mf1 (cond ((eq (key-bindings key 0) 'control-prefix) 'control-prefix) (prefix (arraycall t (key-bindings prefix 0) key)) (t (key-bindings key metap)))) (cond ((eq mf1 'escape) (minibuffer-print-noclear "esc-") (return (key-prompt-1 1 (get-char) nil))) ((eq mf1 'control-prefix) ((lambda (next-char) (cond ((and (> next-char (1- (CtoI "@"))) (< next-char (1+ (CtoI "_")))) (return (key-prompt-1 metap (- next-char (CtoI "@")) prefix))) ((and (> next-char (1- (CtoI "a"))) (< next-char (1+ (CtoI "z")))) (return (key-prompt-1 metap (- next-char (1- (CtoI "a"))) prefix))) (t (display-error "Bad control character: " (printable next-char))))) (get-char))) ;need to look further ((not (symbolp mf1)) (minibuffer-print-noclear (printable key) " (prefix char): ") (return (key-prompt-1 0 (get-char) key))) (t (minibuffer-print-noclear (printable key)) (return (list metap key prefix)))))) ;;; Execute a "key" as an Emacs command: A "key" is the triplet consisting ;;; of a character, "meta"-bit, and prefix character used to determine the ;;; exact command to be executed. (defun execute-key (metap ch prefix) (let ((command)) ;the command to execute (and (or (= metap 1) prefix) (and (< ch (1+ (CtoI "z"))) (> ch (1- (CtoI "a"))) (setq ch (- ch 40)))) (cond ((not prefix) (setq command (key-bindings ch metap))) (t (setq command (arraycall t (key-bindings prefix 0) ch)))) (cond ((symbolp command) ;normal command (setq last-command-triplet-mpfxk (cond ((= metap 1) 'meta) (t prefix)) last-command-triplet-1 ch) (execute-command command (last-command-triplet) nil)) (t ;a prefix character (let ((next-char (get-char))) (cond ((eq (key-bindings next-char 0) 'control-prefix) (let ((the-char (get-char))) ;controllify next character (cond ((and (> the-char (1- (CtoI "@"))) (< the-char (1+ (CtoI "_")))) (execute-key 0 (- the-char (CtoI "@")) ch)) ((and (> the-char (1- (CtoI "a"))) (< the-char (1+ (CtoI "z")))) (execute-key 0 (- the-char (1- (CtoI "a"))) ch)) (t (ring-tty-bell))))) ;can't be control char (t ;ordinary char after prefix (execute-key 0 next-char ch)))))))) ;;; Command that does real work of ESC (defcom escape-dont-exit-minibuf &numeric-argument (&pass) (prog (nxcn numf negate) a (setq nxcn (get-char)) (cond ((and (> nxcn (1- (CtoI "0"))) (< nxcn (1+ (CtoI "9")))) ;number (or numarg (setq numarg 0)) (setq numarg (+ (- nxcn (CtoI "0")) (* 10. numarg))) (setq numf t) (go a)) ((and (not numf) (= nxcn (CtoI "-"))) ;want negative argument (setq negate t numf t) (go a)) ((and (not numf) (= nxcn (CtoI "+"))) ;want positive argument (setq numf t) (go a)) (t (and numf negate ;negative argument (default -1) (setq numarg (- (or numarg 1)))) (cond (numf (process-char nxcn)) ((eq (key-bindings nxcn 0) 'control-prefix) (control-meta-prefix)) ;ESC-^^ -- control-meta (t (execute-key 1 nxcn nil))))))) ;;; Control prefix: reads characters building the numeric argument if fed ;;; digits; when a non-digit is given, executes the control function of ;;; said character (defcom control-prefix &numeric-argument (&pass) (prog (nxcn numf negate) a (setq nxcn (get-char)) (cond ((and (> nxcn (1- (CtoI "0"))) (< nxcn (1+ (CtoI "9")))) ;number (or numarg (setq numarg 0)) (setq numarg (+ (- nxcn (CtoI "0")) (* 10. numarg))) (setq numf t) (go a)) ((and (not numf) (= nxcn (CtoI "-"))) ;want negative argument (setq negate t numf t) (go a)) ((and (not numf) (= nxcn (CtoI "+"))) ;want positive argument (setq numf t) (go a)) (t (and numf negate ;negative argument (default -1) (setq numarg (- (or numarg 1)))) (cond (numf (process-char nxcn)) ((eq (key-bindings nxcn 0) 'escape) (control-meta-prefix)) ;^^-ESC: control-meta ((and (> nxcn (1- (CtoI "@"))) (< nxcn (1+ (CtoI "_")))) (process-char (- nxcn (CtoI "@")))) ((and (> nxcn (1- (CtoI "a"))) (< nxcn (1+ (CtoI "z")))) (process-char (- nxcn (1- (CtoI "a"))))) (t (ring-tty-bell)))))) &documentation "Used to enter control characters when the terminal or network uses those characters for its own purposes. If $$$ is followed by digits or the minus sign (-) or plus sign (+), a numeric argument is collected just as is done for $$escape$. (E.g: Typing $$$123$$go-to-line-number$ will go to line 123). Typing $$$-S is equivalent to typing ^S; typing $$$-$$escape$-S is equivalent to typing $$escape$-^S.") ;;; Control-meta prefix: reads characters building the numeric argument if fed ;;; digits; when a non-digit is given, executes the ESC-control function of ;;; said character (defcom control-meta-prefix &numeric-argument (&pass) (prog (nxcn numf negate) a (setq nxcn (get-char)) (cond ((and (> nxcn (1- (CtoI "0"))) (< nxcn (1+ (CtoI "9")))) ;number (or numarg (setq numarg 0)) (setq numarg (+ (- nxcn (CtoI "0")) (* 10. numarg))) (setq numf t) (go a)) ((and (not numf) (= nxcn (CtoI "-"))) ;want negative argument (setq negate t numf t) (go a)) ((and (not numf) (= nxcn (CtoI "+"))) ;want positive argument (setq numf t) (go a)) (t (and numf negate ;negative argument (default -1) (setq numarg (- (or numarg 1)))) (cond (numf (process-char nxcn)) ((and (> nxcn (1- (CtoI "@"))) (< nxcn (1+ (CtoI "_")))) (execute-key 1 (- nxcn (CtoI "@")) nil)) ((and (> nxcn (1- (CtoI "a"))) (< nxcn (1- (CtoI "z")))) (execute-key 1 (- nxcn (1- (CtoI "a"))) nil)) (t (ring-tty-bell))))))) (set-permanent-key '^^ 'control-prefix) (sstatus uuolinks nil)  vt52.ctl.lisp 11/30/82 1542.2rew 11/30/82 1528.8 19584 ;;; *********************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; *********************************************************** ;;; ;;; -*-LISP-*- ;;; ;;; VT52 control package ;;; BSG 3/21/78 from DD4000ctl ;;; (declare (special X Y screenheight screenlinelen)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) ; Initialize terminal and terminal control package. (defun DCTL-init () (setq idel-lines-availablep nil idel-chars-availablep nil) (setq screenheight 24. screenlinelen 79.) (setq tty-type 'vt52) (Rtyo 33)(Rprinc "H")(Rtyo 33)(Rprinc "J") (setq X 0 Y 0)) ; Move terminal's cursor to desired position. (defun DCTL-position-cursor (x y) (cond ((and (= x X)(= y Y)) nil) ((and (= x 0)(= y 0)) (Rtyo 33)(Rprinc "H") (setq X 0 Y 0)) ((and (< (+ (abs (- X x))(abs (- Y y))) 4)) (cond ((< X x) (do ex X (1+ ex)(= ex x)(Rtyo 33)(Rprinc "C"))) ((< x X) (do ex x (1+ ex)(= ex X)(Rtyo 010)))) (cond ((< Y y) (do wy Y (1+ wy)(= wy y)(Rtyo 33)(Rprinc "B"))) ((< y Y) (do wy y (1+ wy)(= wy Y)(Rtyo 33)(Rprinc "A")))) (setq X x Y y)) ;; Direct Cursor Addressing is best. (t (setq X x Y y) (Rtyo 33)(Rprinc "Y")(Rtyo (+ 40 y))(Rtyo (+ 40 x)) ))) ; Output string. (defun DCTL-display-char-string (string) (setq X (+ X (stringlength string))) (Rprinc string)) ; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (Rtyo 33)(Rprinc "J")) ; Clear to end of line. (defun DCTL-kill-line () (Rtyo 33)(Rprinc "K"))  mowse_fansi.ctl.lisp 07/17/87 1230.6rew 07/17/87 1058.0 71964 ;;; ****************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Bull Inc., 1987 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; ****************************************************** ;;; HISTORY COMMENTS: ;;; 1) change(87-06-24,Coppola), approve(87-06-24,MCR7699), ;;; audit(87-06-24,LJAdams), install(87-07-17,MR12.1-1042): ;;; Add Emacs support (via this ctl) for MOWSE users with FANSI-CONSOLE ;;; installed in their PC's. ;;; END HISTORY COMMENTS ;;; ;;; ;;; FANSI-CONSOLE control package for MOWSE ;;; Created: 11 May 1987 from vt102 control package ;;; (%include e-macros) (declare (*expr Rprinc Rtyo DCTL-standard-set-modes)) (declare (special X Y screenheight screenlinelen ospeed given-tty-type)) (declare (special idel-lines-availablep idel-chars-availablep tty-type)) (declare (special DCTL-prologue-availablep DCTL-epilogue-availablep DCTL-underline-mask)) (declare (special region-scroll-availablep scroll-region-top scroll-region-bottom DCTL-insert-mode-on)) (declare (defpl1 not_ascii_ "" (char (*) aligned) (return bit (1) aligned))) ;;; Macro to output escape sequence (defun fansi-escape macro (form) (list 'Rprinc (apply 'catenate (cons (ItoC 33) (cons "[" (cdr form)))))) ;;; Output n to the terminal in decimal. (defun DCTL-outdec (n) ;BSG 3/23/79 (let ((have-output)) (do digi '(1000. 100. 10. 1) (cdr digi) (null digi) ((lambda (rem) (cond ((or have-output (> rem 0) (= (car digi) 1)) (Rtyo (+ 60 rem)) (setq have-output t))) (setq n (\ n (car digi)))) (// n (car digi)))))) ;;; Output padding, based on n pad characters at 9600-baud (defun DCTL-pad (n) (do-times (// (* n ospeed) 960.) (Rtyo 0)))) ;;; Initialize terminal and terminal control package. (defun DCTL-init () (setq DCTL-prologue-availablep t DCTL-epilogue-availablep t) (setq DCTL-underline-mask t) (setq idel-lines-availablep t idel-chars-availablep t) (setq region-scroll-availablep nil) (setq screenheight 24.) (setq screenlinelen 79.) (memq given-tty-type '(fansi mowse_fansi mowsef)) (setq tty-type 'fansi) (DCTL-prologue) (DCTL-home-cursor) (DCTL-clear-rest-of-screen)) ;;; Initialization that must also be done after a QUIT (defun DCTL-prologue () (Rtyo 33) (Rprinc "<") ;set ANSI mode from VT52 mode (fansi-escape "r") ;reset scroll region (fansi-escape "4l") ;reset insert mode (fansi-escape "20l") ;turn off auto-CRLF (DCTL-pad 102.) (setq scroll-region-top 0 scroll-region-bottom (1- screenheight)) (setq DCTL-insert-mode-on nil)) ;;; Restore terminal to outside state (defun DCTL-epilogue () (fansi-escape "r") ;reset scroll region (fansi-escape "4l") ;reset insert mode (fansi-escape "20h") ;turn on auto-CRLF (DCTL-pad 4) (setq DCTL-insert-mode-on nil)) ;;; Move terminal's cursor to desired position. ;;; Relative cursor movement commands are confined to the current scrolling region. Absolute movement commands can ;;; address the entire screen if if Origin Mode is reset. Missing arguments in the absolute positioning command default ;;; to one. Relative commands can be used if the scroll boundaries are examined. (defun DCTL-position-cursor (x y) (let ((deltax (- x X)) (deltay (- y Y))) (cond ((= deltay 0) (cond ((= deltax 0) nil) ((> deltax 0) ;move right (fansi-escape) (if (not (= deltax 1)) (DCTL-outdec deltax)) (Rprinc "C")) (t (cond ((= x 0) ;move left (fansi-escape) (Rprinc "G")) (t (fansi-escape) (DCTL-outdec (- deltax)) (Rprinc "D")))))) ((= deltax 0) ;;make sure scroll region doesn't screw us. (cond ((or (and (> y scroll-region-bottom) (not (> Y scroll-region-bottom))) (and (< y scroll-region-top) (not (< Y scroll-region-top)))) (fansi-absolute-position x y)) ((> deltay 0) ;move down (fansi-escape) (DCTL-outdec deltay) (Rprinc "B")) (t (fansi-escape) ;move up (DCTL-outdec (- deltay)) (Rprinc "A")))) (t (fansi-absolute-position x y))) (setq X x Y y))) ;;; Perform absolute cursor positioning (defun fansi-absolute-position (x y) (fansi-escape) (if (not (= y 0)) (DCTL-outdec (1+ y))) (if (not (= x 0)) (Rprinc ";") (DCTL-outdec (1+ x))) (Rprinc "H")) ;;; Output string. (defun DCTL-display-char-string (string) (let ((strx (stringlength string))) (cond ((= strx 0)) ;bug in redisplay calls with no string (t (cond (DCTL-insert-mode-on (setq DCTL-insert-mode-on nil) (fansi-escape "4l") (DCTL-pad 1.))) ;reset insert mode (DCTL-output-underlined-string string) (setq X (+ X strx)))))) (defun DCTL-output-underlined-string (string) (cond ((zerop (not_ascii_ string)) ;optimize standard string (Rprinc string)) (t (let ((un nil)) (mapc '(lambda (ch) (cond ((< (CtoI ch) 400) ;normal char (and un (fansi-escape "m")) ;out of underline mode (setq un nil) (Rprinc ch)) (t ;underlined char (400-bit set) (or un (fansi-escape "4m")) (setq un t) (Rtyo (- (CtoI ch) 400))))) (explodec string)) (and un (fansi-escape "m")))))) ;;; Home cursor to upper left corner. (defun DCTL-home-cursor () (setq X 0 Y 0) (fansi-escape H)) ;;; Clear to end of screen. (defun DCTL-clear-rest-of-screen () (fansi-escape J)) ;;; Clear to end of line. (defun DCTL-kill-line () (fansi-escape K)) ;;; Define the bounds of the scroll region. Relative cursor ;;; movement can only be done within this region. (defun DCTL-define-scroll-region (top bottom) (cond ((and (= top scroll-region-top) (= bottom scroll-region-bottom))) (t (setq scroll-region-top top scroll-region-bottom bottom) (fansi-escape "s") ;save cursor position (fansi-escape) ;redefine scroll region (homes) (cond ((not (= top 0)) (DCTL-outdec (1+ top)))) (cond ((not (= bottom (1- screenheight))) (Rprinc ";") (DCTL-outdec (1+ bottom)))) (Rprinc "r") (fansi-escape "u") ;restore cursor position (DCTL-pad 5.)))) ;;; Insert n lines at the current cursor position (defun DCTL-insert-lines (n) (fansi-escape) (DCTL-outdec n) (Rprinc "L")) ;;; Delete n lines at the current cursor position (defun DCTL-delete-lines (n) (fansi-escape) (DCTL-outdec n) (Rprinc "M")) ;;; Move text in scroll region up n lines (inserts whitespace at bottom) (defun DCTL-scroll-up-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (let ((oldy Y)) (fansi-escape) (DCTL-outdec nlines) (Rprinc "S") (setq Y oldy))) ;;; Move text in scroll region down n lines (inserts whitespace at top) (defun DCTL-scroll-down-region (nlines bottom) (DCTL-define-scroll-region Y bottom) (fansi-escape) (DCTL-outdec nlines) (Rprinc "T")) ;;; Insert given text at the cursor (defun DCTL-insert-char-string (string) (fansi-escape) (DCTL-outdec (stringlength string)) (Rprinc "@") (DCTL-output-underlined-string string) (setq X (+ X (stringlength string)))) ;;; Delete N characters at the cursor (defun DCTL-delete-chars (n) (fansi-escape) (and (> n 1) (DCTL-outdec n)) (Rprinc "P") (DCTL-pad n)) bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved