1 ;;; ***********************************************************
 2 ;;; *                                                         *
 3 ;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
 4 ;;; *                                                         *
 5 ;;; * Copyright (c) 1978 by Massachusetts Institute of        *
 6 ;;; * Technology and Honeywell Information Systems, Inc.      *
 7 ;;; *                                                         *
 8 ;;; ***********************************************************
 9 ;;;
10 ;;;
11 ;;;       IBM 3101 control package
12 ;;;        Coded:  29 October 1979 by GMP
13 ;;;
14 
15 (declare (special given-tty-type tty-type ospeed idel-lines-availablep idel-chars-availablep
16                   screenheight screenlinelen X Y))
17 
18 ;;; Initialize terminal and terminal control package
19 (defun DCTL-init ()
20        (setq screenheight 24. screenlinelen 79.)
21        (cond ((eq given-tty-type 'ibm3101_2x)     ;has insert/delete line/character
22               (setq idel-lines-availablep t idel-chars-availablep t))
23              (t                                   ;assume it doesn't have them
24               (setq idel-lines-availablep nil idel-chars-availablep nil)))
25        (setq tty-type 'ibm3101)
26        (Rtyo 33) (Rprinc "H") (Rtyo 33) (Rprinc "J")   ;home and clear screen
27        (setq X 0 Y 0))
28 
29 ;;; Position terminal's cursor to desired position
30 (defun DCTL-position-cursor (x y)
31        (cond ((and (= x X) (= y Y)) nil)          ;already in correct position
32              ((and (= x 0) (= y 0))               ;wants to home the cursor
33               (Rtyo 33) (Rprinc "H")
34               (setq X 0 Y 0))
35              ((and (< (+ (abs (- X x)) (abs (- Y y))) 4))   ;can use relative motion
36               (cond ((< X x)
37                      (do ex X (1+ ex) (= ex x) (Rtyo 33) (Rprinc "C")))
38                     ((< x X)
39                      (do ex x (1+ ex) (= ex X) (Rtyo 010))))
40               (cond ((< Y y)
41                      (do wy Y (1+ wy) (= wy y) (Rtyo 33) (Rprinc "B")))
42                     ((< y Y)
43                      (do wy y (1+ wy) (= wy Y) (Rtyo 33) (Rprinc "A"))))
44               (setq X x Y y))
45              (t (setq X x Y y)                    ;direct cursor addressing is the right thing
46                 (Rtyo 33) (Rprinc "Y") (Rtyo (+ 40 y)) (Rtyo (+ 40 x)))))
47 
48 
49 ;;; Output the given string
50 (defun DCTL-display-char-string (string)
51        (setq X (+ X (stringlength string)))
52        (Rprinc string))
53 
54 
55 ;;; Clear to end of screen
56 (defun DCTL-clear-rest-of-screen ()
57        (Rtyo 33) (Rprinc "J"))
58 
59 
60 ;;; Clear to end of line
61 (defun DCTL-kill-line ()
62        (Rtyo 33) (Rprinc "I"))
63 
64 
65 ;;; Insert character string in line at current position
66 (defun DCTL-insert-char-string (string)
67        (do i 1 (1+ i) (> i (stringlength string))
68            (Rtyo 33) (Rprinc "P") (Rprinc (substr string i 1))
69            (DCTL-pad 100))
70        (setq X (+ X (stringlength string))))
71 
72 
73 ;;; Delete characters from the current position in the line
74 (defun DCTL-delete-chars (n)
75        (do i 1 (1+ i) (> i n)
76            (Rtyo 33) (Rprinc "Q") (DCTL-pad 100)))
77 
78 
79 ;; Insert blank lines at the current position
80 (defun DCTL-insert-lines (n)
81        (do i 1 (1+ i) (> i n)
82            (Rtyo 33) (Rprinc "N") (DCTL-pad 100))
83        (setq X 0))
84 
85 
86 ;;; Delete lines at current position
87 (defun DCTL-delete-lines (n)
88        (do i 1 (1+ i) (> i n)
89            (Rtyo 33) (Rprinc "O") (DCTL-pad 100))
90        (setq X 0))
91 
92 
93 ;;; Pad for specified number of milliseconds
94 (defun DCTL-pad (n)
95        (do i (1+ (// (* n ospeed) 1000.)) (1- i) (= i 0)
96            (Rtyo 177)))