;;; -*- Mode:LISP; Package:HACKS; Base:8; Readtable:ZL -*-

;;; 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 #o60)			; 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 (BYTE 1 0) 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-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)
  (WHEN 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 DEDUCE-SWITCH-REGISTER-SPACING (WIDTH HEIGHT)
  (DECLARE (:SELF-FLAVOR SWITCH-REGISTER-MIXIN))
  (LET ((CHAR-WIDTH (WIDTH-OF-CHARACTER FONTS:TOG CHAR-ORIGIN))
	(CHAR-HEIGHT (TV:FONT-CHAR-HEIGHT FONTS:TOG))
	(CELL-WIDTH (TRUNCATE WIDTH N-SWITCHES))
	(CELL-HEIGHT HEIGHT))
    (IF (AND (< CHAR-WIDTH CELL-WIDTH)
	     (< CHAR-HEIGHT CELL-HEIGHT))
	(PROG () (RETURN (TRUNCATE (- CELL-WIDTH CHAR-WIDTH) 2)
			 (TRUNCATE (- CELL-HEIGHT CHAR-HEIGHT) 2)
			 CELL-WIDTH))
	NIL)))

(DEFUN SET-SWITCH-REGISTER-SPACING ()
  (DECLARE (:SELF-FLAVOR 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" :PACKAGE "FONTS"))
  (IF (GET INIT-PLIST ':LIGHTS)
      (SETQ CHAR-ORIGIN 101))
  (SETQ MOUSE-BLINKER (TV:MAKE-BLINKER SELF 'TV:HOLLOW-RECTANGULAR-BLINKER))
  (SEND MOUSE-BLINKER :SET-VISIBILITY NIL)
  (SEND 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 #o0001 (+ BYTE-SPEC #o0100))
		  (I 0 (1+ I)))
		 (( I N-SWITCHES)
		  (SETQ COLOR-PATTERN PATTERN))
	       (IF (ODDP (TRUNCATE I N-BITS))
		   (SETQ PATTERN (DPB 1 BYTE-SPEC PATTERN))))))))
  (SET-SWITCH-REGISTER-SPACING))
	 
(DEFMETHOD (SWITCH-REGISTER-MIXIN :AFTER :REFRESH) (&REST IGNORE)
  (WHEN (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 SWITCH-REGISTER-CELL (X)
  (DECLARE (:SELF-FLAVOR SWITCH-REGISTER-MIXIN))
  (MIN (TRUNCATE 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)))
    (SEND MOUSE-BLINKER :SET-CURSORPOS
			(- (+ START-X (* CELL X-SPACING)) 2)
			(- START-Y 2))
    (SEND MOUSE-BLINKER :SET-VISIBILITY T)))

(DEFMETHOD (SWITCH-REGISTER-MIXIN :AFTER :HANDLE-MOUSE)  ()
  (SEND 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 (APPLY #'MAKE-INSTANCE 'SWITCH-REGISTER
				:EDGES-FROM ':MOUSE
				:EXPOSE-P T
				:N-SWITCHES 8.
				OPTIONS)))

(DEFFLAVOR MUNCH-WINDOW () (TV:BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER))

(DEFFLAVOR MUNCH-BITS-PANE () (TV:WINDOW)
  (:DEFAULT-INIT-PLIST :BLINKER-P NIL :LABEL NIL))

(DEFFLAVOR MUNCH-SWITCH-REGISTER-PANE () (SWITCH-REGISTER-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: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-))

(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)
	 (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*
	(MAKE-INSTANCE '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 #o401));TRY ALSO 1, 10421, 11111, 100001, ETC.
  (IF (NULL *MUNCH-WINDOW*) (MAKE-MUNCH-WINDOW '#o(140 130 1140 1300)))
  (LET ((BITS-PANE (SEND *MUNCH-WINDOW* :GET-PANE 'BITS))
	(OLD-SELECTED-WINDOW TV:SELECTED-WINDOW))
    (UNWIND-PROTECT
	(PROGN
	  (SEND *MUNCH-WINDOW* :EXPOSE)
	  (SEND BITS-PANE :SELECT) 
	  (SEND BITS-PANE :DO-MUNCHING
			  INITIAL-VALUE 
			  (SEND *MUNCH-WINDOW* :GET-PANE 'NUMBER)
			  (SEND *MUNCH-WINDOW* :GET-PANE 'SREG)))
      (SEND *MUNCH-WINDOW* :DEACTIVATE)
      (SEND 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)
		     (TRUNCATE (- (TV:SHEET-INSIDE-WIDTH) 256.) 2)))
	(Y-OFFSET (+ (TV:SHEET-INSIDE-TOP)
		     (TRUNCATE (- (TV:SHEET-INSIDE-HEIGHT) 256.) 2))))
    (SEND SELF :CLEAR-WINDOW)
    (SEND NUMBER-PANE :PRINT-OUT VALUE)
    (SEND SREG-PANE :SET-VALUE VALUE)
    (CATCH 'QUIT-MUNCHING
      (LOOP WITH RUNNING-P = T
	    DO (LOOP AS CHAR = (SEND SELF :TYI-NO-HANG)
		     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)
					(SEND NUMBER-PANE :PRINT-OUT VALUE)
					(SEND 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))
			       (AS-2-REVERSE
				 (LOGXOR 1 (AR-2-REVERSE TV:SCREEN-ARRAY X Y))
				 TV:SCREEN-ARRAY X Y)))))))))

(DEFUN MUNCH-PROCESS-CHAR (CHAR -VALUE-)
  (DECLARE (:SELF-FLAVOR MUNCH-SWITCH-REGISTER-PANE))
  (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 (TRUNCATE (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 MUNCH-HELP-PANE)