;;; -*- LISP -*-
;;;  A B C
;;;   D E
;;;  F G H

(COND ((NOT (MEMQ 'CURSORPOS (STATUS FILEM TYO)))
       (CURSORPOS 'A TYO)
       (PRINC '|Sorry, THINK-A-DOT currently only works on display terminals.|)
       (TERPRI TYO)
       (QUIT)))

(SSTATUS RANDOM (APPLY '* (APPEND (STATUS DATE) (STATUS DAYTIME))))

(EVAL-WHEN (EVAL COMPILE)
	   (SSTATUS MACRO /# '(LAMBDA () ((LAMBDA (IBASE) (READ)) 2.))))

(EVAL-WHEN (EVAL COMPILE)
	   (DO ((C (TYI) (TYI))
		(L () (CONS C L)))
	       ((= C 31.) (SETQ LONG-RULES (MAKNAM (NREVERSE L))))))

     Think-a-dot is sold as a children's game, but can be played by 
people of all ages. It allows as much or as little planning as you want
to put into it.
     The equipment needed is a plastic box with colored dots on the 
side of it and 5 holes (three on top, one on each side), as shown on the
next screen. (Note: A well-designed think-a-dot simulator running on a PDP-10
may substitute for the plastic box.)

		      A       B       C
                     ___     ___     ___   
		 ----------------------------
		 |                          |
		 |   (A)      (B)    (C)    |
                 |   Blue   Yellow   Blue   |
		 |			    |
		 |			    |
		 |	  (D)	   (E)	    |
		 |      Yellow   Yellow     |
		 |			    |
		 |			    |
		 |   (F)      (G)    (H)    |
		 |   Blue   Yellow   Blue   |
		 |			    |
		||			    ||
	P1	||			    ||	   P2
		------------------------------

     Balls are dropped into the holes depending on which side of the
board they come out on, that player plays next. (It is deterministic
which side of the board they will come out on, as will be seen in a 
minute).
     When a ball falls into a hole, it will strike the dot just
below it, changing its color from blue to yellow or yellow to blue
as appropriate. Depending on the resulting color, the ball will then
fall to either the right or the left and strike the next dot below it.
When it reaches the bottom dot, it will roll out of the box and it will
be the player's turn whose side it rolled out on.

     In this version of think we use "/" and "\" to represent the two
states of the `dots.' This makes it easier to tell what the internal 
state of the machine is. If you are unsure of what happens when a ball
is dropped, play around with the game before starting a game.
     For example, note that when you start with state 11111111 and then
drop a ball into "A" what happens is that it hits node "A" and falls to the 
right (complementing "A"). It then hits node "D" and falls to the right
(complementing it) and finally hits "G" falling to the right (complementing
it).
     If the ball falls out to the left or the right of node "F", or to
the left of node "G", it will be player 1's turn. If it falls to the 
right of node "G" or either side of node "H" it will be player 2's turn.

     If you get stuck, ask a 6-year-old or a mathemetician to help you.
(Note that this box can be viewed as a finite state machine with 256 states,
only 128 of which are reachable from any given state (parity of the 
initial situation is a factor)). Good luck!



(EVAL-WHEN (EVAL COMPILE)
	   (DO ((C (TYI) (TYI))
		(L () (CONS C L)))
	       ((= C 31.) (SETQ SHORT-RULES (MAKNAM (NREVERSE L))))))
[A,B,C] will drop a ball in the hole above corresponding location.
For scored games... <CR> starts. "Q" quits. <LF> restarts game.
Just for fun... "R" randomize board (conserving parity). <Alt>
complements a single switch (reading a switch name). "^S" stores
the current state for later recall. "^R" recalls a previously 
stored state. The characters "/", "\", "-", and "+" initialize 
the board in various interesting ways.
And finally... "H" gives full documentation, "^Q" quits program.


(DEFUN -*-SHORT-RULES-*- MACRO (()) `',SHORT-RULES)

(DEFUN -*-LONG-RULES-*- MACRO (()) `',LONG-RULES)

(SETQ SHORT-RULES (-*-SHORT-RULES-*-) LONG-RULES (-*-LONG-RULES-*-))

(DEFUN LAMBDA MACRO (X) (LIST 'FUNCTION X))

(NOINTERRUPT T)

(DECLARE (*FEXPR *DROP *INIT)
	 (SPECIAL OBJECT-LIST PARITY-LIST
		  TTY-SPEC-INFO \ // MODE REMEMBER
		  SHORT-RULES LONG-RULES))

(SETQ OBJECT-LIST '(A B C D E F G H))
(SETQ PARITY-LIST '(A B C     F G H))

(DEFPROP A (F . D) POINTER)
(DEFPROP B (D . E) POINTER)
(DEFPROP C (E . H) POINTER)
(DEFPROP D (F . G) POINTER)
(DEFPROP E (G . H) POINTER)

;;; Display locations

(DEFPROP A (2 . 6.) WHERE)
(DEFPROP B (2 . 10.) WHERE)
(DEFPROP C (2 . 14.) WHERE)
(DEFPROP D (4 . 8.) WHERE)
(DEFPROP E (4 . 12.) WHERE)
(DEFPROP F (6 . 6.) WHERE)
(DEFPROP G (6 . 10.) WHERE)
(DEFPROP H (6 . 14.) WHERE)

;;; State

(DEFUN *INIT FEXPR (DIR)
       (COND ((INIT (CAR DIR))
	      (TERPRI TYO)
	      (PRINC '|(Initialized)| TYO)
	      (WASH))))

(DEFUN INIT (DIR)
       (COND ((GET 'GAME 'BEING-PLAYED)
	      (TERPRI TYO)
	      (PRINC '|(Game in progress. Can't quit now!)| TYO)
	      ())
	     (T
	      (LET ((STATE (CASEQ DIR (+ '\) (- '//))))
		   (MAPC (LAMBDA (X) (PUTPROP X STATE 'STATE))
			 OBJECT-LIST)
		   T))))

(INIT '+)

(DEFUN INVERT (X) (CDR (ASSQ X '((// . \) (\ . //)))))

(DEFUN STATE (X) (GET X 'STATE))

(DEFUN *COMPLEMENT (X)
       (LET ((STATE (INVERT (STATE X))))
	    (PUTPROP X STATE 'STATE)
	    STATE))

(DEFUN COMPLEMENT FEXPR (X) (*COMPLEMENT (CAR X)))

(DEFUN DISPLAY ()
       (CURSORPOS 0. 0. TYO)
       (CURSORPOS 'L TYO)
       (COND (MODE
	      (PRINC '|Score is | TYO)
	      (PRINC // TYO)
	      (PRINC '| to | TYO)
	      (PRINC \ TYO)
	      (PRINC '|. | TYO)
	      (PRINC MODE TYO))
	     (T
	      (PRINC '|State= | TYO)
	      (LET ((BASE 2.))
		   (MAPCAR 'PRINC
			   (EXTEND
			    (MAPCAR (FUNCTION (LAMBDA (X) (- X 48.)))
				    (EXPLODEN (SGET))))))))
       (MAPC 'DISPLAY-STATE OBJECT-LIST)
       (CURSORPOS 'A TYO)
       (TERPRI TYO)
       (COND ((GET 'GAME 'BEING-PLAYED)
	      (COND ((EQ (GET 'GAME 'WHOSE-TURN) '//)
		     (PRINC '| <- You play next.| TYO))
		    (T
		     (PRINC '| You play next. ->| TYO))))))


(DEFUN DISPLAY-STATE (X)
       (LET (((H . V) (GET X 'WHERE))
	     (STATE (STATE X)))
	    (CURSORPOS H V TYO)
	    (PRINC X)
	    (CURSORPOS 'D TYO)
	    (CURSORPOS 'B TYO)
	    (PRINC     '| | TYO)
	    (CURSORPOS 'B TYO)
	    (PRINC (OR (GET X STATE) STATE) TYO)))

(DEFUN PROMPT ()
       (GAME-END-CHECK)
       (DISPLAY)
       (TERPRI TYO)
       (TERPRI TYO)
       (TYI TYI))

(DEFUN WASH () (CURSORPOS 'E TYO))

(DEFUN EXECUTE ()
       (UNWIND-PROTECT (PROGN (TTY-OFF) (EXECUTE1)) (TTY-ON)))

(SETQ DIAMOND-1 #01011010)
(SETQ DIAMOND-2 #10100101)

(DEFUN EXECUTE1 ()
       (CURSORPOS 'C TYO)
       (DO ((C (PROMPT) (PROMPT)))
	   ((= C 17.) (PRINC '|Quit.| TYO) (QUIT) T)
	   (COND ((OR (= C 65.) (= C 97.)) (*DROP A))
		 ((OR (= C 66.) (= C 98.)) (*DROP B))
		 ((OR (= C 67.) (= C 99.)) (*DROP C))
		 ((OR (= C 82.) (= C 114.)) (*RANDOMIZE))
		 ((OR (= C 81.) (= C 113.))
		  (TERPRI TYO)
		  (COND ((GET 'GAME 'BEING-PLAYED)
			 (TYO 7. TYO)
			 (SETQ MODE '|(Game Halted)|)
			 (REMPROP 'GAME 'BEING-PLAYED)
			 (PRINC '|(Game Halted)| TYO))
			(T
			 (PRINC '|(No game to halt?)| TYO)))
		  (WASH))
		 ((= C 92.) (*INIT +))
		 ((= C 47.) (*INIT -))
		 ((= C 43.)
		  (TERPRI TYO)
		  (COND ((NOT (GET 'GAME 'BEING-PLAYED))
			 (SRESET DIAMOND-2)
			 (PRINC '|(Diamond 2)| TYO))
			(T
			 (PRINC '|(Game in progress?)| TYO)))
		  (WASH))
		 ((= C 45.)
		  (TERPRI TYO)
		  (COND ((NOT (GET 'GAME 'BEING-PLAYED))
			 (SRESET DIAMOND-1)
			 (PRINC '|(Diamond 1)| TYO))
			(T
			 (PRINC '|(Game in progress?)| TYO))) 
		  (WASH))
		 ((= C 12.) (CURSORPOS 'C TYO))
		 ((= C 13.) (GAME-BEGIN))
		 ((= C 10.) (GAME-RESTART))
		 ((OR (= C 32.) (= C 9.)))
		 ((= C 19.) (SREMEMBER))
		 ((= C 18.) (SRECALL))
		 ((= C 27.) (ALTER))
		 ((OR (= C 63.) (= C 2120.))
		  (SHORT-RULES))
		 ((OR (= C 72.) (= C 104.))
		  (LONG-RULES))
		 (T
		  (TYO 7. TYO)
		  (TERPRI TYO)
		  (PRINC '|(Type "?" for help)| TYO)
		  (WASH)))))

(DEFUN *DROP FEXPR (X)
       (SETQ X (CAR X))
       (TERPRI TYO)
       (PRINC `(|Drop| ,X) TYO)
       (WASH)
       (DROP X))

(DEFUN DROP (X)
       (LET* ((STATE (STATE X))
	      (POINTER (GET X 'POINTER))
	      (NEXT (CASEQ STATE (// (CAR POINTER)) (\ (CDR POINTER)))))
	     (*COMPLEMENT X)
	     (COND (NEXT (DROP NEXT))
		   ((EQ X 'F) (DEFPROP GAME // WHOSE-TURN))
		   ((EQ X 'G) (PUTPROP 'GAME STATE 'WHOSE-TURN))
		   (T (DEFPROP GAME \ WHOSE-TURN)))))

(DEFUN INIT-TURN ()
       (PUTPROP 'GAME (COND ((MAYBE) '//) (T '\)) 'WHOSE-TURN))

(DEFUN ALTER ()
       (COND ((NOT (GET 'GAME 'BEING-PLAYED))
	      (CURSORPOS NIL 0. TYO)
	      (CURSORPOS 'L TYO)
	      (PRINC '|Complement: | TYO)
	      (LET ((C (TYI TYI)))
		   (SETQ C (ASCII (COND ((AND (> C 96.) (< C 123.))
					 (SETQ C (- C 32.)))
					(T C))))
		   (TERPRI TYO)
		   (COND ((MEMQ C OBJECT-LIST)
			  (*COMPLEMENT C)
			  (PRINC `(,C |has been complemented|) TYO))
			 (T
			  (PRINC `(|No node | ,C |... Request ignored|) TYO)))
		   (WASH)))
	     (T
	      (TERPRI TYO)
	      (PRINC '|(Game in progress. Don't try to cheat!)| TYO)
	      (WASH))))

(DEFUN MAYBE () (ZEROP (RANDOM 2.)))

(DEFUN *RANDOMIZE ()
       (COND ((GET 'GAME 'BEING-PLAYED)
	      (TERPRI TYO)
	      (PRINC '|(Can't Randomize. Game in progress)| TYO))
	     (T
	      (RANDOMIZE)
	      (PARITY-CHECK)
	      (TERPRI TYO)
	      (PRINC '|(Randomized)| TYO)))
       (WASH))

(DEFUN RANDOMIZE ()
       (MAPC (LAMBDA (X) (COND ((MAYBE) (*COMPLEMENT X))))
	     OBJECT-LIST))

(SETQ MODE () // 0. \ 0.)

(DEFUN GAME-END-CHECK ()
       (COND ((GET 'GAME 'BEING-PLAYED)
	      (DO ((S (STATE (CAR OBJECT-LIST)))
		   (X (CDR OBJECT-LIST) (CDR X)))
		  ((NULL X)
		   (TYO 7. TYO)
		   (SET S (1+ (EVAL S)))
		   (SETQ MODE '|(Game Over)|)
		   (REMPROP 'GAME 'BEING-PLAYED))
		  (COND ((NOT (EQ S (STATE (CAR X))))
			 (RETURN ())))))))

(DEFUN GAME-BEGIN ()
       (COND ((GET 'GAME 'BEING-PLAYED)
	      (TERPRI TYO)
	      (PRINC '|(Game already going?)| TYO))
	     (T
	      (SETQ MODE '|(Game in Progress)|)
	      (INIT-TURN)
	      (PUTPROP 'GAME T 'BEING-PLAYED)
	      (COND ((ZEROP (RANDOM 2.))
		     (SRESET DIAMOND-1))
		    (T
		     (SRESET DIAMOND-2)))
	      (PRINC '|(Game started)| TYO)
	      (WASH))))

(DEFUN GAME-RESTART ()
       (COND ((GET 'GAME 'BEING-PLAYED)
	      (TERPRI TYO)
	      (PRINC '|(Game already going?)| TYO))
	     (T
	      (SETQ MODE '|(Game in Progress)|)
	      (PUTPROP 'GAME T 'BEING-PLAYED)
	      (PRINC '|(Game started)| TYO)
	      (WASH))))

(DEFUN PARITY-CHECK ()
       (LET ((P PARITY-LIST))
	    (DO ((X P (CDR X))
		 (I 0.))
		((NULL X)
		 (COND ((ODDP (+ I)) (*COMPLEMENT (NTH (RANDOM 6.) P)))))
		(COND ((EQ (STATE (CAR X)) '//) (SETQ I (1+ I)))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;; TTY On/Off Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; This section of code written by RWK.

;;; If this is the first time loading the file, save out info on tty
;;; initial specifications.

(COND ((NOT (BOUNDP 'TTY-SPEC-INFO))
       (SETQ TTY-SPEC-INFO (SYSCALL 3. 'TTYGET TYI))))

;;; TTY-OFF
;;;  Turns off automatic echo of input chars on the tty.

(DEFUN TTY-OFF ()
       (SYSCALL 0 'TTYSET TYI
		(BOOLE 1 (CAR TTY-SPEC-INFO) 3272356035.)
		(BOOLE 1 (CADR TTY-SPEC-INFO) 3272356035.)))

;;; TTY-ON
;;;  Re-enable automatic echo of input-chars on the tty.

(DEFUN TTY-ON ()
       (SYSCALL 0 'TTYSET TYI
		(CAR TTY-SPEC-INFO)
		(CADR TTY-SPEC-INFO)))


(DEFUN SGET ()
       (LET ((IBASE 2.))
	    (READLIST (APPEND (MAPCAR 'SGET1 OBJECT-LIST) '(32.)))))

(DEFUN SGET1 (X)
       (COND ((EQ (STATE X) '//) '/0)
	     (T '/1)))

(DEFUN SRESET (X)
       (LET ((BASE 2.))
	    (MAPC 'SRESET1
		  (EXTEND (MAPCAR (FUNCTION (LAMBDA (X) (- X 48.))) (EXPLODEN X)))
		  OBJECT-LIST)))

(DEFUN EXTEND (X)
       (COND ((= (LENGTH X) (LENGTH OBJECT-LIST)) X)
	     (T (EXTEND (CONS 0. X)))))

(DEFUN SRESET1 (STATE OBJECT)
       (PUTPROP OBJECT 
		(COND ((ZEROP STATE) '//)
		      (T '\))
		'STATE))

(DEFUN SRECALL ()
       (TERPRI TYO)
       (COND ((NOT (GET 'GAME 'BEING-PLAYED))
	      (SRESET REMEMBER)
	      (PRINC '|(State Recalled)| TYO))
	     (T
	      (PRINC '|(Game in progress. Can't hack states.)| TYO)))
       (WASH))

(DEFUN SREMEMBER ()
       (TERPRI TYO)
       (SETQ REMEMBER (SGET))
       (PRINC '|(State Stored)| TYO)
       (WASH))


(DEFUN SHORT-RULES ()
       (PRINC SHORT-RULES TYO)
       (WASH))

(DEFUN LONG-RULES ()
       (CURSORPOS 'C TYO)
       (*CATCH 'MORE-FLUSH
	       (PROGN
		(DO ((I 1. (1+ I))
		     (END (FLATC LONG-RULES))
		     (C))
		    ((> I END))
		    (SETQ C (GETCHARN LONG-RULES I))
		    (COND ((= C 12.)
			   (TERPRI TYO)
			   (CURSORPOS 'E TYO)
			   (CLEAR-INPUT TYI)
			   (PRINC '|--Type a Space to See More--| TYO)
			   (COND ((NOT (= (TYI TYI) 32.))
				  (*THROW 'MORE-FLUSH T)))
			   (CURSORPOS 0. 0. TYO))
			  ((= C 13.)
			   (CURSORPOS 'L TYO)
			   (TYO C TYO))
			  (T
			   (TYO C TYO))))
		(TERPRI TYO)
		(PRINC '|--Pause--| TYO)
		(CURSORPOS 'E TYO)
		(TYI TYI)))
       (CURSORPOS 'C TYO))


(DO ((I 0. (1+ I)))
    ((> I 127.))
    (SSTATUS TTYINT I NIL))
(SSTATUS TOPLEVEL '(PROGN (CLEAR-INPUT TYI) (EXECUTE)))
(SETQ TTY-RETURN '(LAMBDA N (CURSORPOS 'C TYO)
			  (DISPLAY)
			  (TERPRI TYO)
			  (TERPRI TYO)))

(LET ((INIT-FILE (PROBEF `((DSK ,(STATUS HSNAME)) ,(STATUS USERID) THINK))))
     (COND (INIT-FILE (LOAD INIT-FILE))))

(INIT '+)

(SETQ REMEMBER 0.)

(NOINTERRUPT NIL)