;;; -*- Mode:Lisp; Base: 8; Package: Hacks -*-

;;; 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.
	  (FUNCALL-SELF ':PLUNK-CHAR
			FONTS:TOG
			(AND S (+ CHAR-ORIGIN (LOW-BIT S) (* 2 C-BIT)))
			(+ CHAR-ORIGIN V-BIT (* 2 C-BIT))
			X
			START-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))
	 (FUNCALL-SELF ':DRAW-RECTANGLE
		       (WIDTH-OF-CHARACTER FONT OLD-CHAR)
		       (TV:FONT-CHAR-HEIGHT FONT)
		       X Y
		       TV:ERASE-ALUF)))
  (FUNCALL-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.
(DECLARE-FLAVOR-INSTANCE-VARIABLES (SWITCH-REGISTER-MIXIN)
(DEFUN DEDUCE-SWITCH-REGISTER-SPACING (WIDTH HEIGHT)
  (LET ((CHAR-WIDTH (WIDTH-OF-CHARACTER FONTS:TOG CHAR-ORIGIN))
	(CHAR-HEIGHT (TV:FONT-CHAR-HEIGHT FONTS:TOG))
	(CELL-WIDTH (// WIDTH N-SWITCHES))
	(CELL-HEIGHT HEIGHT))
    (IF (AND (< CHAR-WIDTH CELL-WIDTH)
	     (< CHAR-HEIGHT CELL-HEIGHT))
	(PROG () (RETURN (// (- CELL-WIDTH CHAR-WIDTH) 2)
			 (// (- CELL-HEIGHT CHAR-HEIGHT) 2)
			 CELL-WIDTH))
	NIL)))
)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SWITCH-REGISTER-MIXIN)
(DEFUN SET-SWITCH-REGISTER-SPACING ()
  (MULTIPLE-VALUE-BIND (INSIDE-WIDTH INSIDE-HEIGHT)
      (FUNCALL-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 (// 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)
	 (FUNCALL-SELF ':UPDATE))))

(DEFMETHOD (SWITCH-REGISTER-MIXIN :SET-VALUE) (NEW-VALUE)
  (SETQ VALUE NEW-VALUE)
  (FUNCALL-SELF ':UPDATE))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (SWITCH-REGISTER-MIXIN)
(DEFUN SWITCH-REGISTER-CELL (X)
  (MIN (// 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)
  (FUNCALL-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)
  (FUNCALL-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)
  (FUNCALL-SELF ':SET-CURSORPOS 0 0)
  (FUNCALL-SELF ':CLEAR-SCREEN)
  (FORMAT SELF "~O" VALUE))

(DEFCONST
  *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."))

(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)
	 (FUNCALL-SELF ':SET-CURSORPOS 0 0)
	 (DO ((L *MUNCH-HELP-LINES* (CDR L)))
	     ((NULL (CDR L))
	      (FUNCALL-SELF ':STRING-OUT (CAR L)))
	   (FUNCALL-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))))

(DEFMETHOD (MUNCH-BITS-PANE :DO-MUNCHING) (INITIAL-VALUE NUMBER-PANE SREG-PANE)
  (LET ((VALUE INITIAL-VALUE)
	(AB 0)
	(X-OFFSET (+ (TV:SHEET-INSIDE-LEFT)
		     (// (- (TV:SHEET-INSIDE-WIDTH) 256.) 2)))
	(Y-OFFSET (+ (TV:SHEET-INSIDE-TOP)
		     (// (- (TV:SHEET-INSIDE-HEIGHT) 256.) 2))))
    (FUNCALL-SELF ':CLEAR-SCREEN)
    (FUNCALL NUMBER-PANE ':PRINT-OUT VALUE)
    (FUNCALL SREG-PANE ':SET-VALUE VALUE)
    (*CATCH 'QUIT-MUNCHING
      (LOOP WITH RUNNING-P = T
	    DO (LOOP AS CHAR = (FUNCALL-SELF ':TYI-NO-HANG)
		     DO (COND ((NULL CHAR)
			       (IF (NOT RUNNING-P)
				   (FUNCALL-SELF ':UNTYI (FUNCALL-SELF ':TYI))))
			      (T
			       (LET ((X (MUNCH-PROCESS-CHAR CHAR VALUE)))
				 (COND ((NUMBERP X)
					(SETQ VALUE (LOGAND 177777 X) AB 0)
					(FUNCALL-SELF ':CLEAR-SCREEN)
					(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 177777 (+ AB VALUE)))
			       (SETQ X (LOGAND AB 377))
			       (SETQ Y (+ Y-OFFSET (LOGXOR X (LDB 1010 AB))))
			       (SETQ X (+ X X-OFFSET))
			       (ASET (LOGXOR 1 (AREF TV:SCREEN-ARRAY X Y))
				     TV:SCREEN-ARRAY X Y)))))))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (MUNCH-SWITCH-REGISTER-PANE)
(DEFUN MUNCH-PROCESS-CHAR (CHAR VALUE)
  (IF (NOT (ATOM CHAR))
      (SELECTQ (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) (- (LDB %%CH-CHAR CHAR) #/0)))
	(#\CLEAR-INPUT
	 0)
	((#/+ #\SP #\HAND-UP)
	 (1+ VALUE))
	((#/- #\HAND-LEFT)
	 (LSH VALUE 1))
	(#/=
	 (1+ (LSH VALUE 1)))
	(#\HAND-RIGHT
	 (LSH VALUE -1))
	(#\HAND-DOWN
	 (1- VALUE))
	(#\CLEAR-SCREEN
	 VALUE)
	((#\HOLD-OUTPUT #\STOP-OUTPUT)
	 'STOP)
	(#\RESUME
	 'GO)
	(OTHERWISE
	  (LET ((BIT-POSITION (FIND-POSITION-IN-LIST
				(CHAR-UPCASE (LDB %%CH-CHAR CHAR))
				'(#/\ #/` #/) #/( #/P #/O #/I #/U
				  #/Y #/T #/R #/E #/W #/Q #\TAB #\NETWORK))))
	    (IF BIT-POSITION
		(LOGXOR VALUE (LSH 1 BIT-POSITION))
		NIL))))))
)

(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 (// (LSH (LOGXOR A B) -2) C)))))

(DEFDEMO "Munching Squares" "A classic display hack from the PDP-1." (MUNCH))

(COMPILE-FLAVOR-METHODS SWITCH-REGISTER-MIXIN SWITCH-REGISTER
			MUNCH-WINDOW MUNCH-BITS-PANE MUNCH-SWITCH-REGISTER-PANE
			MUNCH-NUMBER-PANE)