LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032650. :SYSTEM-TYPE :LOGICAL :VERSION 5. :TYPE "LISP" :NAME "MUNCH" :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 2755629103. :AUTHOR "REL3" :LENGTH-IN-BYTES 12916. :LENGTH-IN-BLOCKS 13. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  ;;; -*- Mode:Common-Lisp; Package:DEMO; Base:8 -*-;;; Ancient MIT CADR hack, converted to Common-Lisp;;; The switch register uses the TOG font to find its characters.  There is a pair;;; of lights at 101 and 102, and a pair of switches at 60 and 61.  They are followed;;; immediately by other pairs (at 103 and 104, and 62 and 63, repectively) by;;; the same thing in the other color.(DEFFLAVOR SWITCH-REGISTER-MIXIN(N-SWITCHES; Number of switches in this register START-X; X-position of first switch START-Y; Y-position of first switch X-SPACING; Spacing between switches (including switch) (VALUE 0); Current value of switch (STATE NIL); Value being displayed, NIL -> bashed. (CHAR-ORIGIN 60); Where in font to find the two chars MOUSE-BLINKER; Blinker for mouse-sensitivity (COLOR-PATTERN NIL); Which color to make the switches )()  (:INCLUDED-FLAVORS TV:WINDOW)  (:GETTABLE-INSTANCE-VARIABLES N-SWITCHES VALUE)  (:INITABLE-INSTANCE-VARIABLES N-SWITCHES VALUE)  (:SETTABLE-INSTANCE-VARIABLES COLOR-PATTERN)  (:INIT-KEYWORDS :SWITCHES :LIGHTS :OCTAL :HEX :RADIX)  );;; Get the least significant bit of a number.(DEFSUBST LOW-BIT (X)  (LDB 0001 X));;; This is the method to update the screen, given the;;; old STATE and new VALUE.  It draws characters and updates STATE.(DEFMETHOD (SWITCH-REGISTER-MIXIN :UPDATE) ()  ;; Loop from right to left, from least significant bit up.  (DO ((X (+ START-X (* (1- N-SWITCHES) X-SPACING)) (- X X-SPACING))       (V VALUE (LSH V -1))       (C COLOR-PATTERN (LSH C -1))       (S STATE)       (I 0 (1+ I)))      ((>= I N-SWITCHES))    ;; The character should be redisplayed if STATE is NIL, or if the bit in    ;; STATE is different from the bit in VALUE.    (LET ((V-BIT (LOW-BIT V)); Current bit of VALUE.  (C-BIT (LOW-BIT C))); Current bit of COLOR-PATTERN.      (IF (OR (NULL S)      (/= V-BIT (PROG1 (LOW-BIT S) (SETQ S (LSH S -1)))))  ;; Character needs to be redrawn.  (SEND SELF ':PLUNK-CHARFONTS:TOG(AND S (+ CHAR-ORIGIN (LOW-BIT S) (* 2 C-BIT)))(+ CHAR-ORIGIN V-BIT (* 2 C-BIT))XSTART-Y))))  (SETQ STATE VALUE))(DEFUN WIDTH-OF-CHARACTER (FONT CHAR)  (LET ((TABLE (TV:FONT-CHAR-WIDTH-TABLE FONT)))    (IF TABLE (AREF TABLE CHAR) (TV:FONT-CHAR-WIDTH FONT))));;; This function is like :DRAW-CHAR, but it does not overwrite.  It erases;;; the old character at the location (except if OLD-CHAR is NIL it does;;; not erase anything), and draws the new character.(DEFMETHOD (SWITCH-REGISTER-MIXIN :PLUNK-CHAR) (FONT OLD-CHAR NEW-CHAR X Y)  (COND ((NOT (NULL OLD-CHAR)) (SEND SELF ':DRAW-RECTANGLE       (WIDTH-OF-CHARACTER FONT OLD-CHAR)       (TV:FONT-CHAR-HEIGHT FONT)       X Y       TV:ERASE-ALUF)))  (SEND SELF ':DRAW-CHAR FONT NEW-CHAR X Y));;; This function deduces the internal spacing given the size of the;;; window and N-SWITCHES.  You give it the new width and height,;;; and it returns the start-x, start-y, and x-spacing, or else NIL;;; if the width or height is unacceptable.(DEFUN-METHOD DEDUCE-SWITCH-REGISTER-SPACING SWITCH-REGISTER-MIXIN (WIDTH HEIGHT)  (LET ((CHAR-WIDTH (WIDTH-OF-CHARACTER FONTS:TOG CHAR-ORIGIN))(CHAR-HEIGHT (TV:FONT-CHAR-HEIGHT FONTS:TOG))(CELL-WIDTH (floor WIDTH N-SWITCHES))(CELL-HEIGHT HEIGHT))    (when (AND (< CHAR-WIDTH CELL-WIDTH)       (< CHAR-HEIGHT CELL-HEIGHT))      (VALUES (floor (- CELL-WIDTH CHAR-WIDTH) 2)      (floor (- CELL-HEIGHT CHAR-HEIGHT) 2)      CELL-WIDTH))))(DEFUN-METHOD SET-SWITCH-REGISTER-SPACING SWITCH-REGISTER-MIXIN ()  (MULTIPLE-VALUE-BIND (INSIDE-WIDTH INSIDE-HEIGHT)      (SEND SELF ':INSIDE-SIZE)    (MULTIPLE-VALUE-BIND (SX SY XS)(DEDUCE-SWITCH-REGISTER-SPACING INSIDE-WIDTH INSIDE-HEIGHT)      (COND ((NOT (NULL SX))     (SETQ START-X SX START-Y SY X-SPACING XS))))))(DEFMETHOD (SWITCH-REGISTER-MIXIN :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE)  (SET-SWITCH-REGISTER-SPACING))(DEFMETHOD (SWITCH-REGISTER-MIXIN :VERIFY-NEW-EDGES) (IGNORE IGNORE WIDTH HEIGHT)  (IF (DEDUCE-SWITCH-REGISTER-SPACING WIDTH HEIGHT)      NIL      "Not enough room for that many switches."))(DEFMETHOD (SWITCH-REGISTER-MIXIN :AFTER :INIT) (INIT-PLIST)  (IF (NOT (BOUNDP 'FONTS:TOG))      (LOAD "SYS:FONTS;TOG" "fonts"))  (IF (GET INIT-PLIST ':LIGHTS)      (SETQ CHAR-ORIGIN 101))  (SETQ MOUSE-BLINKER (TV:MAKE-BLINKER SELF 'TV:HOLLOW-RECTANGULAR-BLINKER))  (FUNCALL MOUSE-BLINKER ':SET-VISIBILITY NIL)  (FUNCALL MOUSE-BLINKER ':SET-SIZE   (+ (TV:FONT-BLINKER-WIDTH FONTS:TOG) 4)   (+ (TV:FONT-BLINKER-HEIGHT FONTS:TOG) 4))         (COND ((NULL COLOR-PATTERN) ;; User didn't specify a color pattern, make an alternating one. (LET ((RADIX (GET INIT-PLIST ':RADIX)))   (LET ((N-BITS (COND ((NOT (NULL RADIX))(1- (HAULONG RADIX)))       ((GET INIT-PLIST ':HEX) 4)       (T 3))))     (DO ((PATTERN 0)  (BYTE-SPEC 0001 (+ BYTE-SPEC 100))  (I 0 (1+ I))) ((>= I N-SWITCHES)  (SETQ COLOR-PATTERN PATTERN))       (IF (ODDP (floor I N-BITS))   (SETQ PATTERN (DPB 1 BYTE-SPEC PATTERN))))))))  (SET-SWITCH-REGISTER-SPACING)) (DEFMETHOD (SWITCH-REGISTER-MIXIN :AFTER :REFRESH) (&REST IGNORE)  (COND ((NULL TV:RESTORED-BITS-P) (SETQ STATE NIL) (SEND SELF ':UPDATE))))(DEFMETHOD (SWITCH-REGISTER-MIXIN :SET-VALUE) (NEW-VALUE)  (SETQ VALUE NEW-VALUE)  (SEND SELF ':UPDATE))(DEFUN-METHOD SWITCH-REGISTER-CELL SWITCH-REGISTER-MIXIN (X)  (MIN (floor X X-SPACING) (1- N-SWITCHES)))(DEFMETHOD (SWITCH-REGISTER-MIXIN :MOUSE-BUTTONS) (IGNORE X IGNORE)  (LET ((BITS (- N-SWITCHES (SWITCH-REGISTER-CELL X) 1)))    (PROCESS-RUN-FUNCTION "SREG click"  SELF  ':NEW-MOUSE-VALUE  (LOGXOR VALUE (LSH 1 BITS)))));;; This message exists specifically so that you can put daemons on it.(DEFMETHOD (SWITCH-REGISTER-MIXIN :NEW-MOUSE-VALUE) (NEW-VALUE)  (SETQ VALUE NEW-VALUE)  (SEND SELF ':UPDATE))(DEFMETHOD (SWITCH-REGISTER-MIXIN :MOUSE-MOVES) (X IGNORE)  (TV:MOUSE-SET-BLINKER-CURSORPOS)  (LET ((CELL (SWITCH-REGISTER-CELL X)))    (FUNCALL MOUSE-BLINKER ':SET-CURSORPOS     (- (+ START-X (* CELL X-SPACING)) 2)     (- START-Y 2))    (FUNCALL MOUSE-BLINKER ':SET-VISIBILITY T)))(DEFMETHOD (SWITCH-REGISTER-MIXIN :AFTER :HANDLE-MOUSE)  ()  (FUNCALL MOUSE-BLINKER ':SET-VISIBILITY NIL));;; (DEFFLAVOR SWITCH-REGISTER () (SWITCH-REGISTER-MIXIN TV:WINDOW);;;   (:DEFAULT-INIT-PLIST;;;     :BLINKER-P NIL;;;     :LABEL NIL;;;     :SAVE-BITS T;;;     :FONT-MAP (LIST FONTS:TOG)));;; ;;; ;;; TESTING;;; ;;; (DEFVAR S);;; ;;; (DEFUN S (&REST OPTIONS);;;   (SETQ S (LEXPR-FUNCALL #'TV:MAKE-WINDOW 'SWITCH-REGISTER;;;  ':EDGES-FROM ':MOUSE;;;  ':EXPOSE-P T;;;  ':N-SWITCHES 10;;;  OPTIONS)))(DEFFLAVOR MUNCH-WINDOW () (TV:BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER))(DEFFLAVOR MUNCH-BITS-PANE () (TV:PANE-MIXIN TV:WINDOW)  (:DEFAULT-INIT-PLIST :BLINKER-P NIL :LABEL NIL))(DEFFLAVOR MUNCH-SWITCH-REGISTER-PANE () (SWITCH-REGISTER-MIXIN TV:PANE-MIXIN TV:WINDOW)  (:DEFAULT-INIT-PLIST :BLINKER-P NIL :LABEL NIL :N-SWITCHES 16.))(DEFMETHOD (MUNCH-SWITCH-REGISTER-PANE :AFTER :NEW-MOUSE-VALUE) (NEW-VALUE)  (SEND SELF ':FORCE-KBD-INPUT (LIST ':NEW-MOUSE-VALUE NEW-VALUE)))(DEFFLAVOR MUNCH-NUMBER-PANE () (TV:BORDERS-MIXIN TV:TOP-BOX-LABEL-MIXIN TV:PANE-MIXIN TV:WINDOW)  (:DEFAULT-INIT-PLIST :BLINKER-P NIL :LABEL NIL       :MORE-P NIL :FONT-MAP '(FONTS:43VXMS)))(DEFMETHOD (MUNCH-NUMBER-PANE :PRINT-OUT) (VALUE)  (SEND SELF ':SET-CURSORPOS 0 0)  (SEND SELF ':CLEAR-WINDOW)  (FORMAT SELF "~O" VALUE))#+ti(DEFPARAMETER  *MUNCH-HELP-LINES*  '("To modify value in switches: NETWORK through \ keys"    "toggle corresponding switches. - and = shift in bits."    "Numbers shift in three bits.  CLEAR-INPUT zeroes."    "Hands up and down increment and decrement, hands"    "right and left shift.  N gets next higher number with"    "same number of one bits. END exits."    "HOLD OUTPUT stops the action, RESUME resumes it."))#+3600(DEFPARAMETER  *MUNCH-HELP-LINES*  '("To modify value in switches: TAB through COMPLETE keys"    "toggle corresponding switches. ~ and = shift in bits."    "Numbers shift in three bits.  CLEAR-INPUT zeroes."    "+ and - increment and decrement, > and < right and"    "left shift.  N gets next higher number with"    "same number of one bits. END exits."    "SQUARE stops the action, RESUME resumes it."))(DEFFLAVOR MUNCH-HELP-PANE () (TV:WINDOW-PANE)  (:DEFAULT-INIT-PLIST :BLINKER-P NIL :LABEL NIL :MORE-P NIL))(DEFMETHOD (MUNCH-HELP-PANE :AFTER :REFRESH) (&OPTIONAL TYPE)  (AND (OR (NOT TV:RESTORED-BITS-P) (EQ TYPE ':SIZE-CHANGED))       (TV:SHEET-FORCE-ACCESS (SELF) (SEND SELF ':SET-CURSORPOS 0 0) (DO ((L *MUNCH-HELP-LINES* (CDR L)))     ((NULL (CDR L))      (SEND SELF ':STRING-OUT (CAR L)))   (SEND SELF ':LINE-OUT (CAR L))))))(DEFVAR *MUNCH-WINDOW* NIL)(DEFUN MAKE-MUNCH-WINDOW (EDGES)  (SETQ *MUNCH-WINDOW*(TV:MAKE-WINDOW  'MUNCH-WINDOW  ':EDGES EDGES  ':PANES '((NUMBER MUNCH-NUMBER-PANE :LABEL "Munching Squares")    (BITS MUNCH-BITS-PANE)    (SREG MUNCH-SWITCH-REGISTER-PANE)    (HELP MUNCH-HELP-PANE))  ':CONSTRAINTS    `((MAIN . ((NUMBER BITS SREG HELP)       ((NUMBER 1 :LINES))       ((SREG 0.2S0))       ((HELP ,(LENGTH *MUNCH-HELP-LINES*) :LINES))       ((BITS :EVEN))))))))(DEFUN MUNCH (&OPTIONAL (INITIAL-VALUE 401));TRY ALSO 1, 10421, 11111, 100001, ETC.  (IF (NULL *MUNCH-WINDOW*) (MAKE-MUNCH-WINDOW '(140 130 1140 1300)))  (LET ((BITS-PANE (FUNCALL *MUNCH-WINDOW* ':GET-PANE 'BITS))(OLD-SELECTED-WINDOW TV:SELECTED-WINDOW))    (UNWIND-PROTECT      (PROGN(FUNCALL *MUNCH-WINDOW* ':EXPOSE)(FUNCALL BITS-PANE ':SELECT) (FUNCALL BITS-PANE ':DO-MUNCHING INITIAL-VALUE  (FUNCALL *MUNCH-WINDOW* ':GET-PANE 'NUMBER) (FUNCALL *MUNCH-WINDOW* ':GET-PANE 'SREG)))      (FUNCALL *MUNCH-WINDOW* ':DEACTIVATE)      (FUNCALL OLD-SELECTED-WINDOW ':SELECT))))#+TI(DEFVAR *EXPLORER-KEY-ROW* '(#\\ #\` #\) #\( #\P #\O #\I #\U #\Y #\T #\R #\E #\W #\Q #\TAB #\NETWORK))#+3600(DEFVAR *3600-KEY-ROW* '(#\COMPLETE #\PAGE #\backspace #\) #\( #\P #\O #\I #\U  #\Y #\T #\R #\E #\W #\Q #\TAB))(DEFUN MUNCH-PROCESS-CHAR (CHAR VALUE)  (IF (NOT (ATOM CHAR))      (case (FIRST CHAR)(:NEW-MOUSE-VALUE (SECOND CHAR)))      (SELECTOR CHAR CHAR-EQUAL(#\END (THROW 'QUIT-MUNCHING NIL))(#\N (NHNWSNOOB VALUE))((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (+ (LSH VALUE 3) (- (char-code char) #\0)))(#\CLEAR-INPUT 0)((#\+ #\SP #+ti #\UP-ARROW) (1+ VALUE))((#\< #\~ #+ti #\- #+ti #\LEFT-ARROW) (LSH VALUE 1))(#\= (1+ (LSH VALUE 1)))((#\> #+ti #\RIGHT-ARROW) (LSH VALUE -1))((#+3600 #\- #+ti #\DOWN-ARROW) (1- VALUE))(#\CLEAR-SCREEN VALUE)(( #+3600 #\SQUARE #+TI #\BREAK #+CADR #\STOP-OUTPUT) 'STOP)(#\RESUME 'GO)(OTHERWISE  (LET ((BIT-POSITION (position(CHAR-UPCASE (char-code char))(the list      #+ti *EXPLORER-KEY-ROW*     #+3600 *3600-KEY-ROW*))))    (IF BIT-POSITION(LOGXOR VALUE (LSH 1 BIT-POSITION))NIL))))))(DEFMETHOD (MUNCH-BITS-PANE :DO-MUNCHING) (INITIAL-VALUE NUMBER-PANE SREG-PANE)  (LET ((VALUE INITIAL-VALUE)(AB 0)(X-OFFSET (+ (TV:SHEET-INSIDE-LEFT)     (floor (- (TV:SHEET-INSIDE-WIDTH) 256.) 2)))(Y-OFFSET (+ (TV:SHEET-INSIDE-TOP)     (floor (- (TV:SHEET-INSIDE-HEIGHT) 256.) 2))))    (SEND SELF ':CLEAR-WINDOW)    (FUNCALL NUMBER-PANE ':PRINT-OUT VALUE)    (FUNCALL SREG-PANE ':SET-VALUE VALUE)    (CATCH 'QUIT-MUNCHING      (LOOP WITH RUNNING-P = T    DO (LOOP AS CHAR = (read-char-no-hang self)     DO (COND ((NULL CHAR)       (IF (NOT RUNNING-P)   (SEND SELF ':UNTYI (SEND SELF ':TYI))))      (T       (LET ((X (MUNCH-PROCESS-CHAR CHAR VALUE))) (COND ((NUMBERP X)(SETQ VALUE (LOGAND #o177777 X) AB 0)(SEND SELF ':CLEAR-WINDOW)(FUNCALL NUMBER-PANE ':PRINT-OUT VALUE)(FUNCALL SREG-PANE ':SET-VALUE VALUE))       ((EQ X 'GO)(SETQ RUNNING-P T))       ((EQ X 'STOP)(SETQ RUNNING-P NIL))))))       (IF RUNNING-P   (TV:PREPARE-SHEET (SELF)     (DO ((X) (Y)) ((TV:KBD-HARDWARE-CHAR-AVAILABLE))       (SETQ AB (LOGAND #o177777 (+ AB VALUE)))       (SETQ X (LOGAND AB #o377))       (SETQ Y (+ Y-OFFSET (LOGXOR X (LDB 1010 AB))))       (SETQ X (+ X X-OFFSET))       (setf (Aref TV:SCREEN-ARRAY Y X)     (LOGXOR 1 (AREF TV:SCREEN-ARRAY Y X)))))))))))(DEFUN NHNWSNOOB (A);NEXT HIGHER NUMBER WITH SAME NUMBER OF ONE BITS (SEE HAKMEM)  (IF (ZEROP A)      0      (LET* ((C (LOGAND A (- 0 A)))     (B (+ A C)))(LOGIOR B (floor (LSH (LOGXOR A B) -2) C)))))(DEFDEMO "Munching Squares" "A classic display hack from the PDP-1." (MUNCH))(COMPILE-FLAVOR-METHODS MUNCH-WINDOW MUNCH-BITS-PANE MUNCH-SWITCH-REGISTER-PANEMUNCH-NUMBER-PANE MUNCH-HELP-PANE)   do (progn(funcall *atan-window* ':clear-screen)(draw-atan-internal size mul *atan-window*)(when (char= #\END (funcall *atan-window* ':tyi))  (return-from atan-demo))))))(comment ;it isn't interesting enough to be in the menu.(defdemo "Atan (arc tangent xor hack)" "Plot low-order bit of the arctangent of Y over X in a window." (atan-demo)))(defun draw-atan-internal (si