github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-03-10 20:53:40 +00:00
Code Issues Releases Wiki Activity
Files
1489766847481e8cde1fbd7e3f5509987734825b
PDP-10.its/src/libdoc/window.cjr1
Eric Swenson 92db560d8f Added lots of new LSPLIB packages (and their sources).
2018-03-22 10:38:13 -07:00

568 lines
18 KiB
Plaintext
Executable File
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;display window package
;chuck rieger, nov. 1975
(declare (special w-bottom w-windows w-active tty)
(*lexpr /,print /,prin1 /,princ /,tyo /,read /,readch /,tyi /,cursorpos)
(*expr /,terpri))
(setq w-bottom (cond ((member tty '(1 2)) 20.) (t 32.))
w-windows nil
w-active (or (member tty '(1 2)) (= tty 5)))
(cond (w-active (sstatus terpri t)))
(mapc '(lambda (fn)
(prog (p new)
(cond ((plist (setq new (implode (cons '/, (explode fn))))) (return nil)))
(setq p (plist fn))
loop (cond (p (putprop new (cadr p) (car p))
(setq p (cddr p)) (go loop)))))
'(print prin1 princ tyo terpri read readch tyi cursorpos))
(defun wclear (name)
(cond ((null (get name 'window)) (wwarn 'wclear name))
(t (wclr name t))))
(defun wflash (name)
(cond ((null (get name 'window)) (wwarn 'wflash name))
(t (wclr name nil) (sleep .3) (wclr name nil))))
(defun w-off () (setq w-active nil) (wunsanitize) (/,cursorpos 'c) 'windows-off)
(defun w-on (name)
(cond ((null (get name 'window)) (wwarn 'w-on name))
(t (setq w-active t) (cond (name (wsanitize name))) (wrestart))))
(defun wclr (name mode)
(prog (x y dx dy right)
(cond ((null w-active) (return (/,terpri))))
(setq x (get name 'x) y (get name 'y) dx (get name 'dx) dy (get name 'dy))
(putprop name 0 'cx) (putprop name 1 'cy) (wcursor name)
(cond ((= tty 5) (flashxy (* x 6.) (1- (* (+ x dx) 6.))
(* y 12.) (1- (* (+ y dy) 12.)) (cond (mode 0) (t -1)))
(return t)))
loop (cond ((= dy 0) (gobottom) (return t)))
(setq right (+ x dx))
(/,cursorpos y right)
lp (/,cursorpos 'x)
(setq right (1- right))
(cond ((> right x) (go lp)))
(setq y (1+ y)) (setq dy (1- dy))
(go loop)))
(defun werasel (line col1 col2 char)
(cond ((= tty 5)
(cond ((eq char '/ ) (flashxy (* col1 6.) (+ (* col2 6.) 5.)
(* line 12.) (+ (* line 12.) 11.) 0))
(t
(prog (d dd) (setq d (1+ (- col2 col1)) dd d)
(/,cursorpos line (1+ col2))
loop (/,cursorpos 'x)
(setq d (1- d))
(cond ((> d 0) (go loop)))
lopp (/,princ char) (setq dd (1- dd)) (cond ((> dd 0) (go lopp)))
(return t)))))
(t (prog (d) (setq d (1+ (- col2 col1))) (/,cursorpos line col1)
loop (/,princ char) (setq d (1- d))
(cond ((> d 0) (go loop)))
(return t)))))
(defun werasec (col lin1 lin2 char)
(prog (d) (setq d (1+ (- lin2 lin1))) (/,cursorpos lin1 (1+ col))
loop (cond ((= d 0) (return t))
(t (/,cursorpos 'x) (/,princ char) (/,cursorpos 'd)
(setq d (1- d)) (go loop)))))
(defun wopen (name x y dx dy frame named reset)
(prog (b1 b2)
(cond ((null w-active) (return nil))
((get name 'window) (return (wreset name))))
(setq b1 1 b2 2)
(putprop name (+ x b1) 'x) (putprop name (+ y b1) 'y)
(putprop name (- dx b2) 'dx) (putprop name (- dy b2) 'dy)
(putprop name frame 'frame)
(putprop name named 'named)
(putprop name 1 'cursor)
(putprop name t 'echo)
(putprop name nil 'crlfpurge)
(putprop name nil 'readprompt)
(putprop name t 'showcur)
(putprop name t 'window) (setq w-windows (cons name w-windows))
(cond (reset (wreset name)))
(return name)))
(defun wclose (name)
(cond ((NULL (GET NAME 'WINDOW)) NIL)
((null (get name 'window)) (wwarn 'wclose name))
(w-active
(wclear name)
(wframe name nil)
(remprop name 'window)
(setq w-windows (delete name w-windows))
(gobottom)
t)
(t nil)))
(defun wreset (name)
(cond ((null (get name 'window)) (wwarn 'wreset name))
(w-active
(wframe name t)
(wnam name)
(wclear name)
(gobottom)
t)
(t nil)))
(defun wrestart ()
(cond (w-active
(/,cursorpos 'c)
(mapc '(lambda (x) (wframe x t) (wnam x) (putprop x 0 'cx)
(putprop x 1 'cy) (wcursor x))
w-windows)
(/,cursorpos (1- w-bottom) 0)
(/,princ '-----------------------------------------------------------------------------------------------)
(gobottom)
t)
(t nil)))
(defun wframe (name mode)
(prog (x y dx dy)
(cond ((null w-active) (return nil)))
(setq mode (and mode (get name 'frame)))
(setq x (get name 'x) y (get name 'y) dx (get name 'dx) dy (get name 'dy))
(werasel (1- y) (1- x) (+ x dx) (cond (mode '-) (t '/ )))
(werasel (+ y dy) (1- x) (+ x dx) (cond (mode '-) (t '/ )))
(werasec (1- x) (1- y) (+ y dy) (cond (mode '/|) (t '/ )))
(werasec (+ x dx) (1- y) (+ y dy) (cond (mode '/|) (t '/ )))
(cond (mode
(/,cursorpos (1- y) x) (/,cursorpos 'x) (/,princ '+)
(/,cursorpos (+ y dy) x) (/,cursorpos 'x) (/,princ '+)
(/,cursorpos (1- y) (+ (1+ x) dx)) (/,cursorpos 'x) (/,princ '+)
(/,cursorpos (+ y dy) (+ (1+ x) dx)) (/,cursorpos 'x) (/,princ '+)))
(gobottom)
(return t)))
(defun wname (name na)
(cond ((null (get name 'window)) (wwarn 'wname name))
(t (putprop name na 'named)
(wframe name t)
(wnam name))))
(defun wnam (name)
(prog (lef ch len y)
(cond ((or (null w-active) (null (get name 'named))) (return nil)))
(setq ch (exploden (get name 'named))
len (length ch)
lef (+ (1- (get name 'x))
(lsh (- (+ (get name 'dx) 2) len) -1))
y (1- (get name 'y)))
(werasel y lef (+ lef (1- len)) '/ )
(/,cursorpos y lef) (mapc '/,tyo ch)
(gobottom) (return t)))
(defun wprinc (name exp)
(prog (e x dx d y)
(cond ((or (null w-active) (null name)) (return (/,princ exp)))
((null (get name 'window)) (return (wwarn 'wprinc name))))
(setq x (get name 'x) dx (get name 'dx) y (get name 'y)
d (1+ (get name 'cx))
e (exploden exp))
(cond ((get name 'crlfpurge) (setq e (delq 10. (delq 13. e)))))
(/,cursorpos (+ y (1- (get name 'cy))) (+ x (1- d)))
loop (do ((ctr d (1+ ctr)))
((or (> ctr dx) (null e))
(cond ((null e) (putprop name (1- ctr) 'cx))))
(/,tyo (car e)) (setq e (cdr e)))
(cond (e (winc name 1)
(setq d 1)
(/,cursorpos (+ y (1- (get name 'cy))) x)
(go loop)))
(wcursor name)
(cond ((get name 'hold) (wwait name)))
(gobottom)
(return exp)))
(defun wprint (name exp)
(cond ((or (null w-active) (null name)) (/,print exp))
((null (get name 'window)) (wwarn 'wprint name))
(t (wprinc name exp) (winc name 1) exp)))
(defun wtyo (name n)
(cond ((or (null w-active) (null name)) (/,tyo n))
((null (get name 'window)) (wwarn 'wtyo name))
((and (get name 'crlfpurge) (or (= n 10.) (= n 13.))) n)
(t (cond ((not (< (get name 'cx) (get name 'dx))) (winc name 1)))
(/,cursorpos (+ (get name 'y) (1- (get name 'cy)))
(+ (get name 'x) (get name 'cx)))
(/,tyo n) (putprop name (1+ (get name 'cx)) 'cx)
(cond ((get name 'hold) (wwait name)))
(gobottom)
n)))
(defun wwait (name)
(gobottom) (/,cursorpos 'e)
(/,princ (cond ((get name 'named)) (t name)))
(/,princ '/ /(holding/)/ )
(cond ((eq (/,readch) 'c) (whold name nil))))
(defun wread (name)
(prog (r)
(cond ((or (null w-active) (null name)) (return (/,read)))
((null (get name 'window)) (return (wwarn 'wread name))))
(wprompt name 'read)
(setq r (/,read)) (cond ((get name 'echo) (wprint name r)))
(gobottom) (/,cursorpos 'e)
(return r)))
(defun wprompt (name type)
(gobottom) (/,cursorpos 'e)
(cond ((get name 'readprompt) (/,princ (get name 'readprompt)))
(t (/,princ type) (/,princ '/ request/ from/ )
(/,princ (cond ((get name 'named)) (t name))) (/,princ ':/ ))))
(defun wreadch (name)
(prog (r)
(cond ((or (null w-active) (null name)) (return (/,readch)))
((null (get name 'window)) (return (wwarn 'wreadch name))))
(wprompt name 'readch)
(setq r (/,readch)) (cond ((get name 'echo) (wprint name r)))
(gobottom) (/,cursorpos 'e)
(return r)))
(defun wtyi (name)
(prog (r)
(cond ((or (null w-active) (null name)) (return (/,tyi)))
((null (get name 'window)) (return (wwarn 'wtyi name))))
(wprompt name 'tyi)
(setq r (/,tyi)) (cond ((get name 'echo) (wtyo name r)))
(gobottom) (/,cursorpos 'e)
(return r)))
(defun winc (name amt)
(cond ((or (null w-active) (null name)) (/,terpri))
((null (get name 'window)) (wwarn 'winc name))
((= amt 0) (winc1 name (cond ((= (get name 'cx) 0) 0) (t 1))))
(t (prog (dir) (setq dir (cond ((< amt 0) -1) (t 1)))
loop (winc1 name dir) (setq amt (- amt dir))
(cond ((not (= amt 0)) (go loop)))
(return t)))))
(defun winc1 (name amt)
(prog (cy)
(putprop name 0 'cx)
(setq cy (+ amt (get name 'cy)))
(cond ((> cy (get name 'dy)) (setq cy 1))
((< cy 1) (setq cy (get name 'dy))))
(putprop name cy 'cy)
(werasel (+ (get name 'y) (1- cy))
(get name 'x) (+ (get name 'x) (1- (get name 'dx))) '/ )
(wcursor name)
(gobottom)
(return t)))
(defun wcursor (name)
(/,cursorpos (+ (get name 'y) (1- (get name 'cursor))) (get name 'x))
(/,cursorpos 'x) (/,princ (cond ((get name 'frame) '/|) (t '/ )))
(cond ((get name 'showcur) (/,cursorpos (+ (get name 'y) (1- (get name 'cy)))
(1- (get name 'x)))
(/,princ '-)))
(putprop name (get name 'cy) 'cursor)
(gobottom)
t)
(defun whold (name mode)
(cond ((null (get name 'window)) (wwarn 'whold name))
(t (putprop name mode 'hold) (gobottom) t)))
(defun wecho (name mode)
(cond ((null (get name 'window)) (wwarn 'wecho name))
(t (putprop name mode 'echo) (gobottom) t)))
(defun wcrlfpurge (name mode)
(cond ((null (get name 'window)) (wwarn 'wcrlfpurge name))
(t (putprop name mode 'crlfpurge) (gobottom) t)))
(defun gobottom () (cond (w-active (/,cursorpos w-bottom 0) (/,cursorpos 'e))))
(defun wcurpos (name) (cond ((or (null w-active) (null name))
(cond ((/,cursorpos)) (t (cons linel 0))))
((null (get name 'window)) (wwarn 'wcurpos name))
(t (cons (get name 'cy) (get name 'cx)))))
(defun wsetpos (name y x)
(cond ((or (null w-active) (null name)) (/,cursorpos y x))
((null (get name 'window)) (wwarn 'wsetpos name))
(t (cond (x (putprop name x 'cx)))
(cond (y (putprop name y 'cy)))
(wcursor name)))
(gobottom) t)
(defun wbottom (y) (setq w-bottom y) (gobottom) t)
(defun windowp (name) (get name 'window))
(defun wsize (name)
(cond ((null (get name 'window)) (wwarn 'wsize name))
(t (cons (get name 'dx) (get name 'dy)))))
(defun wsanitize (default-window)
(cond ((null (get default-window 'window)) (wwarn 'wsanitize default-window)))
(mapc '(lambda (old new)
(prog (p)
(cond ((get old 'w-saved-plist) (return nil)))
(putprop old (setq p (plist old)) 'w-saved-plist)
loop (cond (p (remprop old (car p)) (setq p (cddr p)) (go loop)))
(eval (cons 'defun (cons old (subst (list 'quote default-window)
'* new))))))
'(print prin1 princ tyi tyo terpri read readch cursorpos)
'(((x)(wprint * x)) ((x)(wprinc * x)) ((x)(wprinc * x)) (()(wtyi *))
((x)(wtyo * x)) (()(winc * 1)) (()(wread *)) (()(wreadch *))
(x (cond ((= x 0)(wcurpos *))
((= x 2)(wsetpos * (arg 1) (arg 2)))
(t (eval (cadr (assoc (arg 1)
'((f (wsetpos * nil (1+ (cdr (wcurpos *)))))
(b (wsetpos * nil (1- (cdr (wcurpos *)))))
(d (wsetpos * (1+ (car (wcurpos *))) nil))
(u (wsetpos * (1- (car (wcurpos *))) nil))
(c (wclear *))
(t (wsetpos * 1 1))
(z (wsetpos * 1 (cdr (wsize *))))
(e (prog (l1 l2 c1 c2)
(werasel (setq l1 (+ (get * 'y)
(1- (car (wcurpos *)))))
(+ (get * 'x) (cdr (wcurpos *)))
(setq c2 (+ (get * 'x) (1- (get * 'dx))))
'/ )
(setq l2 (+ (get * 'y) (get * 'dy))
c1 (get * 'x))
loop (setq l1 (1+ l1))
(cond ((< l1 l2) (werasel l1 c1 c2 '/ ))
(go loop))
(gobottom)))
(/] (progn (werasel (+ (get * 'y) (1- (car (wcurpos *))))
(+ (get * 'x) (cdr (wcurpos *)))
(+ (get * 'x) (1- (get * 'dx)))
'/ )
(gobottom)))
(x (progn (/,cursorpos (+ (get * 'y) (1- (get * 'cy)))
(+ (get * 'x) (get * 'cx)))
(/,cursorpos 'x)
(putprop * (1- (get * 'cx)) 'cx)
(gobottom))))))))))))
(sstatus uuolinks)
(eval (subst (list 'quote default-window) '*
'(defun w-toplevel () (wprint * (eval (read))))))
(wreadprompt default-window '*)
(sstatus toplevel '(w-toplevel))
(gobottom)
'sanitized)
(defun wunsanitize ()
(sstatus toplevel nil)
(mapc '(lambda (fn)
(prog (p)
(cond ((null (setq p (get fn 'w-saved-plist))) (return nil)))
(remprop fn 'expr) (remprop fn 'lexpr) (remprop fn 'w-saved-plist)
loop (cond (p (putprop fn (cadr p) (car p))
(setq p (cddr p)) (go loop)))))
'(print prin1 princ tyo terpri read readch tyi cursorpos)))
(defun wreadprompt (name prompt)
(cond ((null (get name 'window)) (wwarn 'wreadprompt name))
(t (putprop name prompt 'readprompt))))
(defun wshowcur (name mode)
(cond ((null (get name 'window)) (wwarn 'wshowcur name))
(t (putprop name mode 'showcur) (wcursor name))))
(defun wwarn (call win)
(/,princ 'window/ slave/ warning/ from/ )
(/,princ call) (/,princ ':/ ) (/,princ win)
(/,princ '/ has/ never/ been/ opened/.)
(terpri)
nil)
;remainder of code, except for flashxy, compliments of chuck rich
;ai:rich;tvout >
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GRAPHICS PACKAGE FOR PDP11 TV TERMINALS. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;TV'S HAVE 455. HORIZONTAL LINES OF 576. DOTS EACH (262080. BITS OUT 'O 262144).
;;MEMORY IS ORGANIZED AS 9 64.-BIT WORDS (EQUIV TO 18. 32.-BIT WORDS) PER LINE.
;;THE PDP10 ACCESSES HALF OF SUCH A WORD (OR TWO 16.-BIT CHUNKS) AT ONCE. THESE 32.
;;BITS ARE PACKED LEFT JUSTIFIED INTO THE 36. BITS. TVEND (OR THE LAST WORD OF THE
;;TV-MEMORY) HAS TWO FUNCTIONS: BIT 200000 WHEN ON, COMPLEMENTS THE BLACK/WHITE
;;OUTPUT. BITS 177760 ARE A WORD-COUNTER FOR WHICH 64.-BIT WORD THE FRAME IS TO
;;START ON. FOR WINNAGE THE NUMBER OUGHT TO BE A MULTIPLE OF 9. CHARACTERS ARE 10.
;;LINES HIGH AND 5 POINTS WIDE (RIGHT AND TOP JUSTIFIED). LINE-PITCH IS 12.
;;TV-LINES, CHARACTER-PITCH IS 6 TV-POINTS. THATS 96. CHRS/LINE EXACTLY AND 37.
;;AND 11./12. LINES (3552. CHRS).
(DECLARE (SPECIAL LISP-SYMBOLS))
;;SYMBOLS MUST BE LOADED TO CALL GETCOR, SACONS.
(AND (OR (NOT (BOUNDP 'LISP-SYMBOLS)) (NULL LISP-SYMBOLS))
(PROG2 (VALRET '// :SYMLOD/
p) (SETQ LISP-SYMBOLS T)))
(DEFUN BITWISE-OR MACRO (CALL) (RPLACA CALL 'BOOLE)
(RPLACD CALL (CONS 7. (CDR CALL))))
(DEFUN PROG1 MACRO (CALL)
;;USEFUL FOR KEEPING A VALUE AROUND MOMENTARILY AFTER
;;IT'S DESTROYED BY A SIDE EFFECT, WITHOUT CREATING
;;ANOTHER VARIABLE TO HOLD IT.
(RPLACA CALL 'PROG2)
(RPLACD CALL (CONS T (CDR CALL))))
(DEFUN BITWISE-AND MACRO (CALL) (RPLACA CALL 'BOOLE)
(RPLACD CALL (CONS 1. (CDR CALL))))
;;*PAGE
;;;
;;; LAP ROUTINES
;;;
;;THE FOLLOWING LAP SUBROUTINE INITIALIZES THE TV BUFFER, BY PERFORMING THE SYSTEM
;;CALL TO MAP THE 11'S MEMORY INTO LISP'S ADDRESS SPACE AND CONNING LISP INTO
;;THINKING THAT AREA OF MEMORY IS REALLY A FIXNUM ARRAY.
(LAP TVINIT SUBR)
(ARGS TVINIT (NIL . 0))
(DEFSYM TTSAR-DATA 200107)
(DEFSYM FIXNUM-ARRAY 200)
(DEFSYM IMMEDIATE 1000)
(DEFSYM READ-WRITE-ACCESS 600000)
(HLLOS 0 NOQUIT)
(PUSH FXP D)
(PUSH FXP F)
(PUSH FXP TT)
(MOVEI TT 12)
(PUSHJ P GETCOR)
(SKIPN 0 TT)
(*VALUE)
(ADDI TT 2000)
(MOVEI F -6 TT)
(HRLI F TV-ARRAY-HEADER)
(BLT F -1 TT)
(HRRM TT -6 TT)
(PUSH FXP TT)
(JSP T SACONS)
(POP FXP TT)
(MOVEM A -3 TT)
(HRLI F FIXNUM-ARRAY)
(HLLM F 0 A)
(MOVEI F -5 TT)
(HRRM F 0 A)
(HRLI F TTSAR-DATA)
(HLLM F 1 A)
(HRRM TT 1 A)
(MOVEM A (SPECIAL TV))
(LSH TT -12)
(HRLI TT -11)
(SETZ D)
(*CALL 0 MAP-11-MEMORY-TO-10-ADDRESS-SPACE)
(*VALUE)
(POP FXP TT)
(POP FXP F)
(POP FXP D)
(HLLZS 0 NOQUIT)
(PUSHJ P CHECKI)
(POPJ P)
TV-ARRAY-HEADER
(0 0 0 -17776)
(PUSH P CFIX1)
(JSP TT 2DIMF)
ASAR-ADDRESS
(0)
(710)
(22)
MAP-11-MEMORY-TO-10-ADDRESS-SPACE
(SETZ)
(SIXBIT CORBLK)
(0 0 READ-WRITE-ACCESS IMMEDIATE)
(0 0 -1 IMMEDIATE)
(TT)
(0 0 -2 IMMEDIATE)
(SETZ 0 D)
NIL
(cond ((= tty 5) (tvinit)))
;;THIS ARRAY IS REALLY YOUR TV BUFFER! DOING (STORE (TV <LINE> <COLUMN>) <BITS>)
;;ACTUALLY CAUSES THE BITS TO APPEAR ON YOUR SCREEN. THINGS TO REMEMBER: KEEP THE
;;LAST 4 LOW ORDER BITS CLEAR, AND COORDINATES RUN TOP TO BOTTOM, LEFT TO RIGHT.
(DECLARE (ARRAY* (FIXNUM TV 2.)))
(cond ((= tty 5) (PUTPROP 'TV TV 'ARRAY)))
;;THE 11 HAS A FEATURE WHEREBY ONE OF THE SIXTEEN BOOLEAN FUNCTIONS OF TWO ARGUMENTS
;;MAY BE SPECIFIED, AND ANY ATTEMPT TO WRITE INTO THE 11'S MEMORY WILL ACTUALLY
;;RESULT IN THE FUNCTION SPECIFIED OF THE WORD BEING DEPOSITED AND THE WORD ALREADY
;;THERE IN THE LOCATION. THIS IS DONE BY PUTTING A NUMBER TO INDICATE THE DESIRED
;;FUNCTION IN THE "ALU REGISTER"; THE FIRST WORD AFTER THE 8 PAGES OF TV MEMORY.
;;THE NUMBER IS IN THE HIGH ORDER 8 BITS OF THE WORD.
(DECLARE (SPECIAL :DRAWMODE ANDC SETZ COMP EQV SAME XOR AND SETO IOR SET)
(FIXNUM (DRAWMODE FIXNUM) (FLIPCOLORS FIXNUM))
(FIXNUM :DRAWMODE OLD-DRAWMODE ANDC SETZ COMP EQV SAME XOR AND SETO IOR
SET))
(DEFUN DRAWMODE (MODE)
(PROG1 :DRAWMODE
(SETQ :DRAWMODE MODE)
(STORE (TV 455. 2.)
(BITWISE-OR :DRAWMODE
(BOOLE 2. -268435456. (TV 455. 2.))))))
;;DRAWMODE RETURNS PREVIOUS STATE FOR EASY LAMBDA-BINDING.
(SETQ ANDC 536870912.
SETZ 805306368.
COMP 1342177280.
XOR 1610612736.
EQV 2415919104.
SAME 2684354560.
AND 2952790016.
SETO 3221225472.
IOR 3758096384.
SET 4026531840.
)
;flashxy clears (parity= 0) or complements (parity= -1) the x-y region of the bit raster
;of a tv between and including columns c1 and c1, and between and including
;lines l1 and l2
(declare (notype (flashxy fixnum fixnum fixnum fixnum fixnum))
(fixnum lmask rmask w1 w2 wc1 wc2 line col))
(defun flashxy (c1 c2 l1 l2 parity)
(prog (lmask rmask w1 w2 wc1 wc2)
(setq c2 (1+ c2)
lmask (boole 1 -16. (boole 6 parity (lsh -16. (- 32. (boole 1. 31. c1)))))
rmask (boole 1 -16. (boole 6 parity (lsh -16. (- (boole 1. 31. c2)))))
w1 (lsh c1 -5.)
w2 (lsh c2 -5.)
wc1 (1+ w1)
wc2 (1- w2))
(drawmode (cond ((= parity 0) 2952790016.) (t 1610612736.)));and and xor, respect.
(cond ((= w1 w2)
(setq lmask (boole (cond ((= parity 0) 7) (t 1)) lmask rmask))
(do ((line l1 (add1 line)))
((greaterp line l2))
(store (tv line w1) lmask)))
(t (setq parity (lsh parity 4))
(do ((line l1 (add1 line)))
((greaterp line l2))
(store (tv line w1) lmask)
(store (tv line w2) rmask)
(do ((col wc1 (add1 col)))
((greaterp col wc2))
(store (tv line col) parity)))))))
Reference in New Issue View Git Blame Copy Permalink