LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032644. :SYSTEM-TYPE :LOGICAL :VERSION 4. :TYPE "LISP" :NAME "HCEDIT" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "GRAPHICS-DEMO") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2753213689. :AUTHOR "REL3" :LENGTH-IN-BYTES 9723. :LENGTH-IN-BLOCKS 10. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  ;;; -*- Mode:Common-Lisp; Package:DEMO; Base:10 -*-;;; Hollerith card editor;;; Ancient MIT CADR hack, converted to Common-Lisp(DEFVAR CARD-WINDOW)(DEFCONSTANT CARD-WINDOW-TOP 192)(DEFCONSTANT CARD-WINDOW-BOTTOM 640)(DEFCONSTANT CARD-TOP 96)(DEFCONSTANT CARD-WIDTH 768)(DEFCONSTANT CARD-BOTTOM-HEIGHT 200)(DEFCONSTANT CARD-TOP-HEIGHT 40)(DEFCONSTANT CARD-CUT-SIZE 20)(DEFCONSTANT CARD-MARGIN 24)(DEFCONSTANT CARD-NUMBER-TOP-HEIGHT 12)(DEFCONSTANT CARD-NUMBER-HEIGHT 18)(DEFCONSTANT CARD-LETTER-TOP 2)(DEFVAR CARD-PUNCH-ARRAY)(DEFVAR CARD-IMAGE);;; Draw the outline(DEFUN DRAW-CARD (&AUX (WID (1- CARD-WIDTH)) (TOP (+ CARD-TOP CARD-TOP-HEIGHT))       (TOT (+ CARD-TOP-HEIGHT CARD-BOTTOM-HEIGHT CARD-TOP)))  (SYS:%DRAW-RECTANGLE WID CARD-BOTTOM-HEIGHT 0 TOP TV:ALU-ANDCA CARD-WINDOW)  (SYS:%DRAW-RECTANGLE (- WID CARD-CUT-SIZE) CARD-TOP-HEIGHT CARD-CUT-SIZE CARD-TOP       TV:ALU-ANDCA CARD-WINDOW)  (SYS:%DRAW-TRIANGLE (1- CARD-CUT-SIZE) CARD-TOP (1- CARD-CUT-SIZE) TOP 0 TOP      TV:ALU-ANDCA CARD-WINDOW)  (SYS:%DRAW-LINE (1- CARD-CUT-SIZE) CARD-TOP WID CARD-TOP TV:ALU-IOR T CARD-WINDOW)  (SYS:%DRAW-LINE WID CARD-TOP WID TOT TV:ALU-IOR T CARD-WINDOW)  (SYS:%DRAW-LINE WID TOT 0 TOT TV:ALU-IOR T CARD-WINDOW)  (SYS:%DRAW-LINE 0 TOT 0 TOP TV:ALU-IOR T CARD-WINDOW)  (SYS:%DRAW-LINE 0 TOP (1- CARD-CUT-SIZE) CARD-TOP TV:ALU-IOR T CARD-WINDOW))(DEFUN DRAW-LARGE-NUMBERS ()  (DO ((CHAR #\0 (1+ CHAR))       (Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT) (+ Y CARD-NUMBER-HEIGHT)))      ((> CHAR #\9))    (DO ((I 1. (1+ I)) (X (+ CARD-MARGIN 2) (+ X 9)))((> I 80.))      (SYS:%DRAW-CHARACTER FONTS:TVFONT CHAR nil X Y TV:ALU-IOR CARD-WINDOW))))(DEFUN DRAW-SMALL-NUMBERS (&AUX Y)  (SETQ Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (floor CARD-NUMBER-HEIGHT 2)))  (DRAW-SMALL-NUMBERS-1 Y)  (SETQ Y (+ Y (* CARD-NUMBER-HEIGHT 9)))  (DRAW-SMALL-NUMBERS-1 Y))(DEFUN DRAW-SMALL-NUMBERS-1 (Y)  (DO ((I 1. (1+ I))       (X (+ CARD-MARGIN 2) (+ X 9)))      ((> I 80.))    (DRAW-SMALL-NUMBER I X Y)))(DEFUN DRAW-SMALL-NUMBER (I X Y)    (IF (< I 10.)(SYS:%DRAW-CHARACTER FONTS:TINY (+ I #\0) nil (1+ X) Y TV:ALU-IOR CARD-WINDOW)(SYS:%DRAW-CHARACTER FONTS:TINY (+ (floor I 10.) #\0) nil (1- X) Y TV:ALU-IOR CARD-WINDOW)(SYS:%DRAW-CHARACTER FONTS:TINY (+ (rem I 10.) #\0) nil (+ X 3) YTV:ALU-IOR CARD-WINDOW)))(DEFUN DRAW-LOGO (&AUX X Y)  (SETQ X (+ CARD-MARGIN 2 (* 9 6))Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (* CARD-NUMBER-HEIGHT 10.)))  (DRAW-TINY "IBM" X Y)  (SETQ X (+ X (* 9 2)))  (LET ((X0 (1- X)) (Y0 (1- Y))(X1 (+ X 15.)) (Y1 (+ Y 7)))    (SYS:%DRAW-LINE X0 Y0 X1 Y0 TV:ALU-IOR T CARD-WINDOW)    (SYS:%DRAW-LINE X1 Y0 X1 Y1 TV:ALU-IOR T CARD-WINDOW)    (SYS:%DRAW-LINE X1 Y1 X0 Y1 TV:ALU-IOR T CARD-WINDOW)    (SYS:%DRAW-LINE X0 Y1 X0 Y0 TV:ALU-IOR T CARD-WINDOW))  (DRAW-TINY "5081" X Y))(DEFUN DRAW-TINY (STR X Y)  (DO ((I 0 (1+ I))       (LEN (ARRAY-ACTIVE-LENGTH STR))       (X X (+ X 4)))      ((>= I LEN))    (SYS:%DRAW-CHARACTER FONTS:TINY (AREF STR I) nil X Y TV:ALU-IOR CARD-WINDOW)))(DEFUN DRAW-IT ()  (TV:PREPARE-SHEET (CARD-WINDOW)    (DRAW-CARD)    (DRAW-LARGE-NUMBERS)    (DRAW-SMALL-NUMBERS)    (DRAW-LOGO)))(DEFUN DRAW-CARD-CHAR (CHAR CHAR-X &AUX X BITS)  (TV:PREPARE-SHEET (CARD-WINDOW)    (SETQ X (+ CARD-MARGIN 2 (* CHAR-X 9)))    (SYS:%DRAW-CHARACTER FONTS:TVFONT CHAR nil X    (+ CARD-TOP CARD-LETTER-TOP) TV:ALU-IOR CARD-WINDOW)    (AND (= (SETQ BITS (AREF CARD-PUNCH-ARRAY CHAR)) #o177777) (FERROR NIL "Attempt to punch ~C" CHAR))    (DO ((BITS BITS (LSH BITS -1)) (Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (* CARD-NUMBER-HEIGHT 9))    (- Y CARD-NUMBER-HEIGHT)))((ZEROP BITS))      (AND (zlc:BIT-TEST 1 BITS)   (SYS:%DRAW-RECTANGLE 6 (- CARD-NUMBER-HEIGHT 3) X YTV:ALU-IOR CARD-WINDOW)))))(DEFUN ERASE-CARD-CHAR (CHAR CHAR-X &AUX X BITS)  (TV:PREPARE-SHEET (CARD-WINDOW)    (SETQ X (+ CARD-MARGIN 2 (* CHAR-X 9)))    (SYS:%DRAW-RECTANGLE 5 10. X (+ CARD-TOP CARD-LETTER-TOP) TV:ALU-ANDCA CARD-WINDOW)    (AND (= (SETQ BITS (AREF CARD-PUNCH-ARRAY CHAR)) #o177777) (FERROR NIL "Attempt to unpunch ~C" CHAR))    (DO ((BITS BITS (LSH BITS -1)) (Y (+ CARD-TOP CARD-TOP-HEIGHT CARD-NUMBER-TOP-HEIGHT (* CARD-NUMBER-HEIGHT 9))    (- Y CARD-NUMBER-HEIGHT)) (I 9 (1- I)))((ZEROP BITS))      (COND ((zlc:BIT-TEST 1 BITS)     (SYS:%DRAW-RECTANGLE 6 (- CARD-NUMBER-HEIGHT 3) X Y  TV:ALU-ANDCA CARD-WINDOW)     (COND ((>= I 0)    (SYS:%DRAW-CHARACTER FONTS:TVFONT (+ #\0 I) nil X Y TV:ALU-IOR CARD-WINDOW)    (AND (OR (= I 0) (= I 9)) (DRAW-SMALL-NUMBER (1+ CHAR-X) X    (+ Y (floor CARD-NUMBER-HEIGHT 2)))))))))))(DEFCONSTANT CARD-PUNCH-FORMAT'((#\SP . ())  (#\. . (12. 8 3))  (#\) . (12. 8 4))  (#\] . (12. 8 5))  (#\< . (12. 8 6))  (#\_ . (12. 8 7))  (#\+ . (12.))  (#\! . (11. 8 2))  (#\$ . (11. 8 3))  (#\* . (11. 8 4))  (#\[ . (11. 8 5))  (#\> . (11. 8 6))  (#\& . (11. 8 7))  (#\- . (11.))  (#\/ . (0 1))  (#\' . (0 8 3))  (#\( . (0 8 4))  (#\" . (0 8 5))  (#\# . (0 8 6))  (#\% . (0 8 7))  (#\= . (8 3))  (#\@ . (8 4))  (#\^ . (8 5))  (#\, . (8 6))  (#\\ . (8 7))  (#\A . (12. 1))  (#\B . (12. 2))  (#\C . (12. 3))  (#\D . (12. 4))  (#\E . (12. 5))  (#\F . (12. 6))  (#\G . (12. 7))  (#\H . (12. 8))  (#\I . (12. 9))  (#\J . (11. 1))  (#\K . (11. 2))  (#\L . (11. 3))  (#\M . (11. 4))  (#\N . (11. 5))  (#\O . (11. 6))  (#\P . (11. 7))  (#\Q . (11. 8))  (#\R . (11. 9))  (#\; . (0 8 2))  (#\S . (0 2))  (#\T . (0 3))  (#\U . (0 4))  (#\V . (0 5))  (#\W . (0 6))  (#\X . (0 7))  (#\Y . (0 8))  (#\Z . (0 9))  (#\0 . (0))  (#\1 . (1))  (#\2 . (2))  (#\3 . (3))  (#\4 . (4))  (#\5 . (5))  (#\6 . (6))  (#\7 . (7))  (#\8 . (8))  (#\9 . (9))))(DEFUN INITIALIZE-CARD-PUNCH-ARRAY ()  (OR (BOUNDP 'CARD-PUNCH-ARRAY)      (SETQ CARD-PUNCH-ARRAY (MAKE-ARRAY #o200 ':TYPE 'ART-16B)))  (zlc:FILLARRAY CARD-PUNCH-ARRAY '(-1))  (DOLIST (LIST CARD-PUNCH-FORMAT)    (setf (aref CARD-PUNCH-ARRAY (CAR LIST))  (DO ((PUNCHES (CDR LIST) (CDR PUNCHES))       (PUNCH)       (VALUE 0))      ((NULL PUNCHES) VALUE)    (SETQ PUNCH (CAR PUNCHES))    (AND (< PUNCH 10.) (SETQ PUNCH (- 10. PUNCH)))    (SETQ VALUE (LOGIOR VALUE (LSH 1 (1- PUNCH))))))))(OR (BOUNDP 'CARD-PUNCH-ARRAY) (INITIALIZE-CARD-PUNCH-ARRAY));;; Now the top level editor(DEFUN CARD-EDITOR ()  (SETUP-CARD-WINDOW)  (TV:WINDOW-CALL (CARD-WINDOW :DEACTIVATE)    (FUNCALL CARD-WINDOW ':CLEAR-SCREEN)    (CARD-EDITOR-INTERNAL)))(DEFUN SETUP-CARD-WINDOW ()  (OR (BOUNDP 'CARD-WINDOW)      (SETQ CARD-WINDOW (TV:MAKE-WINDOW 'TV:WINDOW':LABEL NIL':SUPERIOR TV:MOUSE-SHEET':TOP CARD-WINDOW-TOP':BOTTOM CARD-WINDOW-BOTTOM)))  ;; Load fonts if necessary  (FUNCALL (TV:SHEET-GET-SCREEN CARD-WINDOW) ':PARSE-FONT-DESCRIPTOR 'FONTS:TINY)  (FUNCALL (TV:SHEET-GET-SCREEN CARD-WINDOW) ':PARSE-FONT-DESCRIPTOR 'FONTS:TVFONT))(DEFUN CARD-EDITOR-INTERNAL ()  (OR (BOUNDP 'CARD-IMAGE)      (SETQ CARD-IMAGE (MAKE-ARRAY 80. ':TYPE 'ART-STRING ':LEADER-LENGTH 1)))  (STORE-ARRAY-LEADER 0 CARD-IMAGE 0)  (DRAW-IT)  (CATCH 'RETURN-FROM-EDITOR    (DO () (NIL)      (CATCH 'ABORT-COMMAND(PROG (CH)  (FUNCALL CARD-WINDOW ':SET-CURSORPOS    (+ CARD-MARGIN 2 (* (ARRAY-LEADER CARD-IMAGE 0) 9))   (+ CARD-TOP CARD-LETTER-TOP))  (SETQ CH (CHAR-UPCASE (read-char CARD-WINDOW)))  (case CH    (#\CR     (THROW 'RETURN-FROM-EDITOR T))    (#\RUBOUT     (LET ((I (1- (ARRAY-LEADER CARD-IMAGE 0))))       (COND ((MINUSP I)      (BEEP)      (THROW 'ABORT-COMMAND T)))       (ERASE-CARD-CHAR (AREF CARD-IMAGE I) I)       (STORE-ARRAY-LEADER I CARD-IMAGE 0)))    (#\CLEAR     (DO ((I (1- (ARRAY-LEADER CARD-IMAGE 0)) (1- I))) ((MINUSP I))       (ERASE-CARD-CHAR (AREF CARD-IMAGE I) I))     (STORE-ARRAY-LEADER 0 CARD-IMAGE 0))    (OTHERWISE     (COND ((OR (>= CH #o200)(= (AREF CARD-PUNCH-ARRAY CH) #o177777)(NOT (zlc:ARRAY-PUSH CARD-IMAGE CH)))    (BEEP)    (THROW 'ABORT-COMMAND T)))     (DRAW-CARD-CHAR CH (1- (ARRAY-LEADER CARD-IMAGE 0)))))))))  (FUNCALL CARD-WINDOW ':SET-CURSORPOS 0 (+ CARD-TOP-HEIGHT CARD-BOTTOM-HEIGHT CARD-TOP))  CARD-IMAGE)(DEFDEMO "Hollerith Editor" "Upward compatibilty with primitive computers." (CARD-EDITOR))(DEFDEMO "Multiple Hollerith Editor" "Upward compatibilty with primitive computers." (EDIT-MULTIPLE-CARDS))(DEFPARAMETER CARD-Y-OFFSET -16)(DEFPARAMETER CARD-X-OFFSET -5)(DEFUN EDIT-MULTIPLE-CARDS ()  (SETUP-CARD-WINDOW)  (TV:WINDOW-CALL (CARD-WINDOW :DEACTIVATE)    (FUNCALL CARD-WINDOW ':CLEAR-SCREEN)    (DO () (())      (CARD-EDITOR-INTERNAL)      (LET ((X-WID (- (TV:SHEET-INSIDE-WIDTH CARD-WINDOW) (ABS CARD-X-OFFSET)))    (Y-WID (- (TV:SHEET-INSIDE-HEIGHT CARD-WINDOW) (ABS CARD-Y-OFFSET))))(FUNCALL CARD-WINDOW ':BITBLT-WITHIN-SHEET TV:ALU-SETA (IF (< CARD-X-OFFSET 0) X-WID (- X-WID)) (IF (< CARD-Y-OFFSET 0) Y-WID (- Y-WID)) (IF (< CARD-X-OFFSET 0) (- CARD-X-OFFSET) 0) (IF (< CARD-Y-OFFSET 0) (- CARD-Y-OFFSET) 0) (IF (< CARD-X-OFFSET 0) 0 CARD-X-OFFSET) (IF (< CARD-Y-OFFSET 0) 0 CARD-Y-OFFSET))(FUNCALL CARD-WINDOW ':DRAW-RECTANGLE (ABS CARD-X-OFFSET) (TV:SHEET-INSIDE-HEIGHT CARD-WINDOW) (IF (< CARD-X-OFFSET 0)     (+ (TV:SHEET-INSIDE-WIDTH CARD-WINDOW) CARD-X-OFFSET)     0) 0 TV:ALU-ANDCA)(FUNCALL CARD-WINDOW ':DRAW-RECTANGLE (TV:SHEET-INSIDE-WIDTH CARD-WINDOW) (ABS CARD-Y-OFFSET) 0 (IF (< CARD-Y-OFFSET 0)       (+ (TV:SHEET-INSIDE-WIDTH CARD-WINDOW) CARD-Y-OFFSET)       0) TV:ALU-ANDCA)))))eep (+ 500. (floor (* angle key))) tempo))      (funcall *hof-window* ':draw-line (+ 100 (abs (- x1 1000)))       (+ 100 (abs (- y1 1000)))       (+ 100 (abs (- x2 1000)))       (+ 100 (abs (- y2 1000)))       tv:alu-xor))))                                   ;;;) delete "with-real-time"(defun atan* (y x)  (if (and (zerop y) (zerop x)) 0 (atan y x)));Symmetric xoring of 2 triangles(defun birds (x y) (hack-in-m-silent 1 1 2 2 x y y x))(defun hack-in-m-silent (x1-rate y1-rate x2-rate y2-rate x3-ra