(FILECREATED " 8-Dec-85 18:00:53" {ICE}<DENBER>LISP>TM.;16 30118
changes to: (VARS TMCOMS TMDELAY)
(FNS TM ENTERSYMS TMCREATE TMMSG DELTRANS TMMOVEHEAD MSELECT)
(PROPS (0n1n SYMBOLS)
(0n1n TRLIST)
(0n1n STATES)
(0n1n FINALSTATE))
previous date: "15-NOV-83 17:38:44" {ICE}<DENBER>LISP>TM.;15)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT TMCOMS)
(RPAQQ TMCOMS ((VARS CURSYM CURTM OLDTAPE POSITION (PWINDOW)
STATE TAPE TM1 TMDEBUG (TMDELAY 10)
TMHEADX TMLIST TMSYMBOLS (TMVERSION "1.2")
0n1n DEMO2 PONG)
(FNS DELTRANS ENTERSTATES ENTERSYMS EXISTINGSTATES EXISTINGSYMS EXISTINGTRANS ENTERTERMSTATES
GETXY FINDAREA GETDIR GETSTATE GETSYM GETTR MSELECT MAKEBOX MAKETAPE PRINTONTAPE GETTAPE
MAKETRANS MARK MOVEHEAD PAINTOBJ PRINTDIR PRINTSTATE PRINTSYM SAVETAPE SHADEBOX TM
TMCREATE MENUEXEC TMMOVE TMMOVEHEAD TMMSG UPDATETM)
(BITMAPS FINALMAP INITMAP LEFTMAP RIGHTMAP TMHEADMAP HAPPYHEADMAP SADHEADMAP DCURSORMAP
UCURSORMAP LCURSORMAP TCURSORMAP SSCURSORMAP AUTOCURSORMAP)
(PROP (TRLIST TAPE)
QA)
(PROP TRLIST QQ T1)
(PROP SYMBOLS T1)
(PROP ALL 0n1n DEMO2 PONG)))
(RPAQQ CURSYM 0)
(RPAQQ CURTM 0n1n)
(RPAQQ OLDTAPE (0 0 1 1 B B B B B B B))
(RPAQQ POSITION 2)
(RPAQQ PWINDOW NIL)
(RPAQQ STATE 2)
(RPAQQ TAPE (0 0 1 1 %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %]))
(RPAQQ TM1 (((0 2 X 1)
(Y 4 Y 1))
((0 2 0 1)
(1 3 Y -1)
(Y 2 Y 1))
((0 3 0 -1)
(X 1 X 1)
(Y 3 Y -1))
((Y 4 Y 1)
(%] 5 %] 1))
(NIL)))
(RPAQQ TMDEBUG NIL)
(RPAQQ TMDELAY 10)
(RPAQQ TMHEADX 0)
(RPAQQ TMLIST (0n1n DEMO2 PONG "FOO" "foo"))
(RPAQQ TMSYMBOLS (0 1 X Y %]))
(RPAQ TMVERSION "1.2")
(RPAQQ 0n1n "FOO")
(RPAQQ DEMO2 NIL)
(RPAQQ PONG NIL)
(DEFINEQ
(DELTRANS
[LAMBDA NIL (* MJD " 8-Dec-85 17:13")
(PROG (TR SYM STATE STATELIST)
(SETCURSOR DCURSOR)
(TMMSG "Select the transition to be deleted:")
(SETQ TR (GETXY))
[SETQ SYM (CAR (NTH TMSYMBOLS (CAR TR]
[SETQ STATE (CAR (NTH TMSTATES (CDR TR]
(SETQ STATELIST (CAR (NTH (GETPROP CURTM (QUOTE TRLIST))
STATE)))
(RPLACA (NTH (GETPROP CURTM (QUOTE TRLIST))
STATE)
(for I in STATELIST when (NEQ (CAR I)
SYM)
collect I))
(BITBLT NIL NIL NIL PWINDOW (IPLUS (ITIMES (CAR TR)
60)
2)
(IPLUS (IDIFFERENCE 390 (ITIMES STATE 30))
3)
58 27 (QUOTE TEXTURE)
(QUOTE REPLACE)
WHITESHADE)
(CURSOR T)
(TMMSG "Pfft!"])
(ENTERSTATES
[LAMBDA NIL (* MD "27-OCT-83 11:40")
(SETQ TMSTATES (LIST NIL))
(SETQ YLOC 400)
(TMMSG "Enter states (single digits); end with a ]")
(SETQ CHAR (READC))
(until (EQ CHAR (QUOTE %]))
do [COND
((OR (ILEQ (CHCON1 CHAR)
48)
(IGREATERP (CHCON1 CHAR)
57))
(TMMSG "Type a ']' character to finish, or single digits (1-9) to go on."))
(T (SETQ YLOC (IDIFFERENCE YLOC 30))
(MOVETO 5 YLOC PWINDOW)
(PRIN1 (QUOTE q)
PWINDOW)
(PRIN1 CHAR PWINDOW)
(DRAWLINE 5 (IDIFFERENCE YLOC 8)
XLOC
(IDIFFERENCE YLOC 8)
1
(QUOTE PAINT)
PWINDOW)
(SETQ TMSTATES (NCONC1 TMSTATES CHAR))
(PUTPROP CURTM (QUOTE TRLIST)
(APPEND (GETPROP CURTM (QUOTE TRLIST))
(LIST NIL]
(SETQ CHAR (READC)))
(SETQ TMSTATES (CDR TMSTATES))
(PUTPROP CURTM (QUOTE STATES)
TMSTATES)
(for X from 60 to XLOC by 60 do (DRAWLINE X 420 X (IDIFFERENCE YLOC 8)
1
(QUOTE PAINT)
PWINDOW])
(ENTERSYMS
[LAMBDA NIL (* MJD " 8-Dec-85 17:35")
(SETQ TMSYMBOLS (LIST NIL))
(SETQ XLOC 60)
(TMMSG "Type symbols (single characters, no CR's); end with a ]")
(SETQ CHAR (READC))
(to 12 until (EQ CHAR (QUOTE %]))
do [COND
((ILEQ (CHCON1 CHAR)
42)
(TMMSG "Type a ']' character to finish, anything else to go on."))
(T (MOVETO (IPLUS XLOC 10)
400 PWINDOW)
(PRIN1 CHAR PWINDOW)
(SETQ TMSYMBOLS (NCONC1 TMSYMBOLS CHAR))
(SETQ XLOC (IPLUS XLOC 60]
(SETQ CHAR (READC)))
(MOVETO (IPLUS XLOC 10)
400 PWINDOW)
(PRIN1 (QUOTE <blank>)
PWINDOW)
(SETQ TMSYMBOLS (NCONC1 TMSYMBOLS (QUOTE %])))
(SETQ XLOC (IPLUS XLOC 60))
(SETQ TMSYMBOLS (CDR TMSYMBOLS))
(PUTPROP CURTM (QUOTE SYMBOLS)
TMSYMBOLS)
(DRAWLINE 5 390 XLOC 390 1 (QUOTE PAINT)
PWINDOW])
(EXISTINGSTATES
[LAMBDA NIL (* MD "27-OCT-83 12:37")
(SETQ TMSTATES (GETPROP CURTM (QUOTE STATES)))
(SETQ YLOC 400)
(for CHAR in TMSTATES
do (SETQ YLOC (IDIFFERENCE YLOC 30))
(MOVETO 5 YLOC PWINDOW)
(PRIN1 (QUOTE q)
PWINDOW)
(PRIN1 CHAR PWINDOW)
(DRAWLINE 5 (IDIFFERENCE YLOC 8)
XLOC
(IDIFFERENCE YLOC 8)
1
(QUOTE PAINT)
PWINDOW))
(BITBLT INITMAP NIL NIL PWINDOW 26 (IDIFFERENCE 400 (ITIMES (GETPROP CURTM (QUOTE INITIALSTATE))
30))
NIL NIL NIL (QUOTE REPLACE))
(BITBLT FINALMAP NIL NIL PWINDOW 26 (IDIFFERENCE 400 (ITIMES (GETPROP CURTM (QUOTE FINALSTATE))
30))
NIL NIL NIL (QUOTE REPLACE))
(for X from 60 to XLOC by 60 do (DRAWLINE X 420 X (IDIFFERENCE YLOC 8)
1
(QUOTE PAINT)
PWINDOW])
(EXISTINGSYMS
[LAMBDA NIL (* MD "25-OCT-83 15:46")
(SETQ TMSYMBOLS (GETPROP CURTM (QUOTE SYMBOLS)))
(SETQ XLOC 60)
(for CHAR in TMSYMBOLS
do (MOVETO (IPLUS XLOC 10)
400 PWINDOW)
(PRIN1 (COND
((EQ CHAR (QUOTE %]))
(QUOTE <blank>))
(T CHAR))
PWINDOW)
(SETQ XLOC (IPLUS XLOC 60)))
(DRAWLINE 5 390 XLOC 390 1 (QUOTE PAINT)
PWINDOW])
(EXISTINGTRANS
[LAMBDA NIL (* MD "19-OCT-83 15:29")
(PROG (STATE TR NEWSTATE NEWSYM)
(for STATE in (GETPROP CURTM (QUOTE TRLIST)) as S# from 1 to (LENGTH TMSYMBOLS)
unless (EQUAL STATE (QUOTE (NIL)))
do (for TR in (REVERSE STATE)
do (SETQ TRXY (CONS (IPLUS (IDIFFERENCE (LENGTH TMSYMBOLS)
(LENGTH (MEMB (CAR TR)
TMSYMBOLS)))
1)
S#))
(SETQ NEWSTATE (CADR TR))
(PRINTSTATE TRXY NEWSTATE)
(SETQ NEWSYM (CADDR TR))
(PRINTSYM TRXY (IPLUS (IDIFFERENCE (LENGTH TMSYMBOLS)
(LENGTH (MEMB NEWSYM TMSYMBOLS)))
1))
(SETQ DIR (CAR (LAST TR)))
(PRINTDIR TRXY)))
(TMMSG "OK"])
(ENTERTERMSTATES
[LAMBDA NIL (* MD "27-OCT-83 12:35")
(TMMSG "Select the initial state:")
(SETCURSOR LCURSOR)
(PUTPROP CURTM (QUOTE INITIALSTATE)
(CDR (GETXY)))
(BITBLT INITMAP NIL NIL PWINDOW 26 (IDIFFERENCE 400 (ITIMES (GETPROP CURTM (QUOTE INITIALSTATE))
30))
NIL NIL NIL (QUOTE REPLACE))
(TMMSG "Select the final state:")
(PUTPROP CURTM (QUOTE FINALSTATE)
(CDR (GETXY)))
(BITBLT FINALMAP NIL NIL PWINDOW 26 (IDIFFERENCE 400 (ITIMES (GETPROP CURTM (QUOTE FINALSTATE))
30))
NIL NIL NIL (QUOTE REPLACE))
(CURSOR T])
(GETXY
[LAMBDA (KEEP) (* MD "25-OCT-83 16:29")
(PROG ((BOX NIL))
(GETMOUSESTATE)
(until (MOUSESTATE LEFT) do (GETMOUSESTATE))
(until (NEQ BOX NIL) do (while (MOUSESTATE LEFT) when (AND (ILESSP (LASTMOUSEX PWINDOW)
XLOC)
(IGREATERP (LASTMOUSEY PWINDOW)
YLOC))
do (SETQ BOX (FINDAREA (LASTMOUSEX PWINDOW)
(LASTMOUSEY PWINDOW)))
(BITBLT NIL NIL NIL PWINDOW (CAR BOX)
(CADR BOX)
(CADDR BOX)
(CAR (LAST BOX))
(QUOTE TEXTURE)
(QUOTE INVERT)
1025)
(DISMISS 5)
(BITBLT NIL NIL NIL PWINDOW (CAR BOX)
(CADR BOX)
(CADDR BOX)
(CAR (LAST BOX))
(QUOTE TEXTURE)
(QUOTE INVERT)
1025)
(GETMOUSESTATE)))
(COND
(KEEP (BITBLT NIL NIL NIL PWINDOW (CAR BOX)
(CADR BOX)
(CADDR BOX)
(CAR (LAST BOX))
(QUOTE TEXTURE)
(QUOTE INVERT)
1025)))
(RETURN (CONS (IQUOTIENT (CAR BOX)
60)
(IQUOTIENT (IDIFFERENCE 400 (CADR BOX))
30])
(FINDAREA
[LAMBDA (X Y) (* MD "18-OCT-83 14:00")
(LIST (ITIMES (IQUOTIENT X 60)
60)
(ITIMES (IQUOTIENT Y 30)
30)
60 30])
(GETDIR
[LAMBDA NIL (* MD "18-OCT-83 15:55")
(TMMSG "Select the direction to move in.")
(MENU (create MENU
ITEMS ←(QUOTE ((LEFT -1)
(RIGHT 1])
(GETSTATE
[LAMBDA NIL (* MD "21-OCT-83 17:01")
(TMMSG "Select the state to go to:")
(CURSOR LCURSOR)
(CDR (GETXY])
(GETSYM
[LAMBDA NIL (* MD "21-OCT-83 17:00")
(TMMSG "Select the symbol to write:")
(SETCURSOR UCURSOR)
(CAR (GETXY])
(GETTR
[LAMBDA NIL (* MD "21-OCT-83 17:04")
(TMMSG "Select a transition:")
(SETCURSOR TCURSOR)
(GETXY])
(MSELECT
[LAMBDA NIL (* MJD " 8-Dec-85 17:49")
(TMMSG "Select the machine you want.")
(SETQ CURTM (MENU (create MENU
ITEMS ← TMLIST
TITLE ← "Choose one:")))
(CLEARW PWINDOW)
(EXISTINGSYMS)
(EXISTINGSTATES)
(EXISTINGTRANS)
[SETQ TAPE (COPY (GETPROP CURTM (QUOTE TAPE]
(MAKETAPE)
(TMMSG CURTM])
(MAKEBOX
[LAMBDA (X Y W H STREAM) (* MD "11-OCT-83 15:34")
(BITBLT NIL NIL NIL STREAM X Y W H (QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE)
(BITBLT NIL NIL NIL STREAM (IPLUS X 1)
(IPLUS Y 1)
(IDIFFERENCE W 2)
(IDIFFERENCE H 2)
(QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE])
(MAKETAPE
[LAMBDA NIL (* MD "26-OCT-83 11:19")
(for I from 1 to 900 by 39 do (MAKEBOX I 20 40 40 PWINDOW))
(for I from 1 to (MIN (LENGTH TAPE)
(IQUOTIENT (WINDOWPROP PWINDOW (QUOTE WIDTH))
40))
as SYM in TAPE do (PRINTONTAPE SYM I))
(COND
((NEQ TMHEADX 0)
(PUTPROP OBJ (QUOTE OPERATION)
(QUOTE ERASE))
(PAINTOBJ OBJ TMHEADX 64 (fetch BITMAPWIDTH of TMHEADMAP)
(fetch BITMAPHEIGHT of TMHEADMAP)
PWINDOW)))
(PUTPROP OBJ (QUOTE OPERATION)
(QUOTE REPLACE))
(PUTPROP OBJ (QUOTE BITMAP)
TMHEADMAP)
(SETQ TMHEADX 0)
(PAINTOBJ OBJ TMHEADX 64 (fetch BITMAPWIDTH of TMHEADMAP)
(fetch BITMAPHEIGHT of TMHEADMAP)
PWINDOW])
(PRINTONTAPE
[LAMBDA (SYM POS) (* MD "25-OCT-83 11:17")
(MOVETO (IDIFFERENCE (ITIMES POS 39)
22)
36 PWINDOW)
(PRIN1 (QUOTE % )
PWINDOW)
(MOVETO (IDIFFERENCE (ITIMES POS 39)
16)
36 PWINDOW)
(PRIN1 (QUOTE % )
PWINDOW)
(MOVETO (IDIFFERENCE (ITIMES POS 39)
22)
36 PWINDOW)
(COND
((NEQ SYM (QUOTE %]))
(PRIN1 SYM PWINDOW])
(GETTAPE
[LAMBDA NIL (* MD "19-OCT-83 15:51")
(PROG (SYM POS (TAPELOC 0))
(TMMSG "Select symbols - click anywhere else in grid to end.")
[SETQ SYM (CAR (NTH TMSYMBOLS (CAR (SETQ POS (GETXY]
[while (EQ (CDR POS)
0)
do (PRINTONTAPE SYM (SETQ TAPELOC (ADD1 TAPELOC)))
(SETQ TAPE (NCONC1 TAPE SYM))
(SETQ SYM (CAR (NTH TMSYMBOLS (CAR (SETQ POS (GETXY]
[for I from (IPLUS (LENGTH TAPE)
1)
to 100 do (SETQ TAPE (NCONC1 TAPE (QUOTE %]]
(TMMSG "OK"])
(MAKETRANS
[LAMBDA NIL (* MD "21-OCT-83 17:04")
(PROG (TR NEWSTATE NEWSYM)
(SETQ TR (GETTR))
(CURSOR T)
(SETQ NEWSTATE (GETSTATE))
(CURSOR T)
(PRINTSTATE TR NEWSTATE)
(SETQ NEWSYM (GETSYM))
(CURSOR T)
(PRINTSYM TR NEWSYM)
(SETQ DIR (GETDIR))
(PRINTDIR TR)
(UPDATETM TR NEWSTATE NEWSYM DIR)
(TMMSG "OK"])
(MARK
[LAMBDA (SYM) (* MD "10-OCT-83 14:33")
(COND
(TMDEBUG (printout T "Writing " SYM T)))
(RPLACA (NTH TAPE POSITION)
SYM)
(MOVETO (IDIFFERENCE (ITIMES POSITION 40)
22)
36 PWINDOW)
(COND
((NEQ SYM (QUOTE B))
(PRIN1 SYM PWINDOW])
(MOVEHEAD
[LAMBDA (DIR) (* MD "27-OCT-83 14:03")
(SETQ POSITION (IPLUS POSITION DIR))
(SETQ CURSYM (CAR (NTH TAPE POSITION)))
(SHADEBOX)
(TMMOVEHEAD TMHEADX 64 TMHEADMAP 4 (ITIMES DIR 4)
DIR PWINDOW])
(PAINTOBJ
[LAMBDA (OBJ X Y W H STREAM) (* MD " 3-JAN-83 14:22")
(BITBLT (GETPROP OBJ (QUOTE BITMAP))
NIL NIL STREAM X Y W H NIL (GETPROP OBJ (QUOTE OPERATION))
NIL NIL])
(PRINTDIR
[LAMBDA (TR) (* MD "25-OCT-83 14:01")
(PROG (ARROW)
(SETQ ARROW (QUOTE ARROW))
(PUTPROP ARROW (QUOTE OPERATION)
(QUOTE REPLACE))
(PUTPROP ARROW (QUOTE BITMAP)
(COND
((EQ DIR 1)
RIGHTMAP)
(T LEFTMAP)))
(PAINTOBJ ARROW (IPLUS (ITIMES (CAR TR)
60)
42)
(IDIFFERENCE 400 (ITIMES (CDR TR)
30))
(fetch BITMAPWIDTH of (GETPROP ARROW (QUOTE BITMAP)))
(fetch BITMAPHEIGHT of (GETPROP ARROW (QUOTE BITMAP)))
PWINDOW])
(PRINTSTATE
[LAMBDA (TR STATE) (* MD "19-OCT-83 10:45")
(MOVETO (IPLUS (ITIMES (CAR TR)
60)
2)
(IDIFFERENCE 400 (ITIMES (CDR TR)
30))
PWINDOW)
(PRIN1 (QUOTE q)
PWINDOW)
(PRIN1 (CAR (NTH TMSTATES STATE))
PWINDOW)
(PRIN1 (QUOTE ,)
PWINDOW])
(PRINTSYM
[LAMBDA (TR X) (* MD "19-OCT-83 15:29")
(MOVETO (IPLUS (ITIMES (CAR TR)
60)
26)
(IDIFFERENCE 400 (ITIMES (CDR TR)
30))
PWINDOW)
(PRIN1 [COND
((EQ (CAR (NTH TMSYMBOLS X))
(QUOTE %]))
(QUOTE % ))
(T (CAR (NTH TMSYMBOLS X]
PWINDOW)
(PRIN1 (QUOTE ,)
PWINDOW])
(SAVETAPE
[LAMBDA NIL (* MD "26-OCT-83 11:22")
(PUTPROP CURTM (QUOTE TAPE)
(COPY TAPE))
(TMMSG "This tape is now saved."])
(SHADEBOX
[LAMBDA NIL (* MD "27-OCT-83 14:01")
(BITBLT NIL NIL NIL PWINDOW (ITIMES (IPLUS (IDIFFERENCE (LENGTH TMSYMBOLS)
(LENGTH (MEMB CURSYM TMSYMBOLS)))
1)
60)
(IDIFFERENCE 390 (ITIMES STATE 30))
60 30 (QUOTE TEXTURE)
(QUOTE INVERT)
1025])
(TM
[LAMBDA NIL (* MJD " 8-Dec-85 17:43")
(PROG (OLDFONT)
(PRINTOUT T "Turing Machine Maker, version " TMVERSION T)
(SETQ TMDEBUG NIL)
[CLEARW (OR PWINDOW
(SETQ PWINDOW
(CREATEW (create REGION
LEFT ← 32
BOTTOM ← 32
WIDTH ← 900
HEIGHT ← 500)
(CONCAT "Turing Machine Maker v. " TMVERSION]
(SETQ PSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM PWINDOW NIL (CONCAT
"Turing Machine Maker v. "
TMVERSION)))
(SETQ OLDFONT (DSPFONT BIGFONT PWINDOW))
(SETQ DCURSOR (CURSORCREATE DCURSORMAP))
(SETQ LCURSOR (CURSORCREATE LCURSORMAP))
(SETQ UCURSOR (CURSORCREATE UCURSORMAP))
(SETQ TCURSOR (CURSORCREATE TCURSORMAP))
(SETQ SSCURSOR (CURSORCREATE SSCURSORMAP))
(SETQ AUTOCURSOR (CURSORCREATE AUTOCURSORMAP))
(SETQ TMHEADX 0)
(SETQ OBJ (QUOTE OBJ))
(SETQ TMMAINMENU (create MENU
ITEMS ← (QUOTE (("Make new machine" TMCREATE
"Will let you create a new Turing machine.")
("Select existing machine" MSELECT
"Will bring up a menu of currently defined machines.")
("Auto run" TMMOVE
"Will automatically execute the current machine.")
("Single step" ONEMOVE
"Will execute the current machine stopping after each move.")
("Add a transition" MAKETRANS
"Will let you add or modify any transition of the current machine.")
("Remove a transition" DELTRANS
"Will delete the specified transition from the graph.")
("Write the tape" GETTAPE
"Will let you create a tape for the machine to run on.")
("Save the tape" SAVETAPE
"Will store the current tape with the current machine.")))
WHENSELECTEDFN ← (QUOTE MENUEXEC)
TITLE ← "Control Menu"
MENUCOLUMNS ← 1
MENUFONT ← BIGFONT))
(TMMSG "Start by doing 'Make new machine' or 'Select existing machine'")
(ATTACHMENU TMMAINMENU PWINDOW (QUOTE TOP)
(QUOTE LEFT])
(TMCREATE
[LAMBDA NIL (* MJD " 8-Dec-85 17:50")
(PROG (NEWNAME)
(CLEARW PWINDOW)
(OR (BOUNDP (QUOTE TMLIST))
(SETQ TMLIST (LIST NIL)))
(TTYDISPLAYSTREAM PSTREAM)
(MOVETOUPPERLEFT PWINDOW)
(SETQ NEWNAME (PROMPTFORWORD "Type in a name for this machine:" NIL NIL PWINDOW))
[COND
((NOT (MEMBER NEWNAME TMLIST))
(SETQ TMLIST (NCONC1 TMLIST NEWNAME]
(SET CURTM NEWNAME)
(SETQ TAPE NIL)
(ENTERSYMS)
(ENTERSTATES)
(ENTERTERMSTATES)
(TMMSG "Select 'Add a transition' to fill in the grid:"])
(MENUEXEC
[LAMBDA (ITEM) (* MD "26-OCT-83 13:44")
(SELECTQ (CADR ITEM)
((TMCREATE MAKETRANS DELTRANS MSELECT SAVETAPE)
(APPLY (CADR ITEM)))
(GETTAPE (SETQ TAPE NIL)
(GETTAPE)
(MAKETAPE))
((TMMOVE ONEMOVE)
(SETQ POSITION 1)
(COND
((NOT TAPE)
(GETTAPE)))
(MAKETAPE)
(SETQ CURSYM (CAR TAPE))
(COND
((EQ (CADR ITEM)
(QUOTE ONEMOVE))
(SETQ TMSSTEP T)
(SETCURSOR SSCURSOR)
(TMMSG "Click Left to move, hold down to Halt."))
(T (SETQ TMSSTEP NIL)
(SETCURSOR AUTOCURSOR)
(TMMSG "Hold down Left to Halt.")))
(TMMOVE (GETPROP CURTM (QUOTE TRLIST))
(GETPROP CURTM (QUOTE INITIALSTATE))
(GETPROP CURTM (QUOTE FINALSTATE)))
(CURSOR T))
(PROGN NIL])
(TMMOVE
[LAMBDA (TABLE STATE GOAL) (* MD "27-OCT-83 14:08")
(PROG (REJECTED FN)
(SETQ REJECTED NIL)
(SHADEBOX)
[until (OR (EQ STATE GOAL)
REJECTED
(MOUSESTATE LEFT))
do (GETMOUSESTATE)
(SETQ FN (for I in (CAR (NTH TABLE STATE)) thereis (EQ (CAR I)
CURSYM)))
(COND
(TMSSTEP (UNTILMOUSESTATE LEFT)))
(COND
(TMDEBUG (printout T "Current state is " STATE T)))
(COND
[(EQ (CAR FN)
CURSYM)
(SHADEBOX)
(SETQ STATE (CADR FN))
(COND
(TMDEBUG (printout T "Going to state " STATE T)))
(MARK (CADDR FN))
(MOVEHEAD (CAR (LAST FN)))
(COND
(TMDEBUG (printout T "Current symbol is " CURSYM T)
(printout T "Tape is now " TAPE T T]
(T (SETQ REJECTED T]
(COND
(REJECTED (PUTPROP (QUOTE OBJ)
(QUOTE BITMAP)
SADHEADMAP)
(BITBLT SADHEADMAP NIL NIL PWINDOW TMHEADX 64 NIL NIL NIL (QUOTE REPLACE))
(TMMSG "Rejected."))
((AND (NOT REJECTED)
(NEQ STATE GOAL))
(TMMSG "Halted by user."))
((NOT REJECTED)
(PUTPROP (QUOTE OBJ)
(QUOTE BITMAP)
HAPPYHEADMAP)
(BITBLT HAPPYHEADMAP NIL NIL PWINDOW TMHEADX 64 NIL NIL NIL (QUOTE REPLACE))
(TMMSG "Accepted.")))
(SHADEBOX])
(TMMOVEHEAD
[LAMBDA (X1 Y1 BITMAP XDELTA SPEED DIR STREAM) (* MJD " 8-Dec-85 17:48")
(PROG (W H OBJ)
(SETQ OBJ (QUOTE OBJ))
(SETQ W (fetch BITMAPWIDTH of BITMAP))
(SETQ H (fetch BITMAPHEIGHT of BITMAP))
(PUTPROP OBJ (QUOTE BITMAP)
BITMAP)
(PUTPROP OBJ (QUOTE OPERATION)
(QUOTE INVERT))
(for X from X1 to (ITIMES (IDIFFERENCE POSITION 1)
39)
by SPEED
do (PAINTOBJ OBJ X Y1 W H STREAM)
(PAINTOBJ OBJ (IPLUS X SPEED)
Y1 W H STREAM)
(DISMISS TMDELAY)
(SETQ TMHEADX (IPLUS X SPEED])
(TMMSG
[LAMBDA (MSG) (* MJD " 8-Dec-85 17:09")
(MOVETOUPPERLEFT PWINDOW)
(SPACES 76 PWINDOW)
(MOVETOUPPERLEFT PWINDOW)
(PRIN1 MSG PWINDOW])
(UPDATETM
[LAMBDA (TR NEWSTATE NEWSYM DIR) (* MD "19-OCT-83 12:41")
(PROG (SYM STATE)
[SETQ SYM (CAR (NTH TMSYMBOLS (CAR TR]
[SETQ STATE (CAR (NTH TMSTATES (CDR TR]
(RPLACA (NTH (GETPROP CURTM (QUOTE TRLIST))
STATE)
(CONS (LIST SYM NEWSTATE (CAR (NTH TMSYMBOLS NEWSYM))
DIR)
(CAR (NTH (GETPROP CURTM (QUOTE TRLIST))
STATE])
)
(RPAQ FINALMAP (READBITMAP))
(32 16
"@@@@@@@@"
"@@@@@@@@"
"GNGNGNGN"
"GNGNGNGN"
"F@AHFFFF"
"F@AHFFFF"
"F@AHFFFF"
"GNAHFFGN"
"GNAHFFGN"
"@FAHFFF@"
"@FAHFFF@"
"@FAHFFF@"
"GNAHGNF@"
"GNAHGNF@"
"@@@@@@@@"
"@@@@@@@@")
(RPAQ INITMAP (READBITMAP))
(32 16
"OO@@@COO"
"H@OOOL@G"
"IL@@@@GM"
"JAOBCLMA"
"J@DEBBAA"
"IHDEBDAA"
"HDDHKHAA"
"HDDOJFAA"
"KHDHJAAA"
"H@@HH@@A"
"OO@@@@CO"
"LAN@@GNC"
"L@COOL@C"
"L@@@@@@C"
"L@@@@@@C"
"L@@@@@@C")
(RPAQ LEFTMAP (READBITMAP))
(16 8
"@C@@"
"@O@@"
"COOO"
"OOOO"
"COOO"
"@O@@"
"@C@@"
"@@@@")
(RPAQ RIGHTMAP (READBITMAP))
(16 8
"@@D@"
"@@G@"
"OOOL"
"OOOO"
"OOOL"
"@@G@"
"@@D@"
"@@@@")
(RPAQ TMHEADMAP (READBITMAP))
(43 53
"AOOOOOOOOON@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@AN@@@AN@B@"
"A@CO@@@CO@B@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@CO@@@CO@B@"
"A@AN@@@AN@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@AOOON@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"@OOOOOOOOOL@"
"@H@@@@@@@@D@"
"@D@@@@@@@@H@"
"@B@@@@@@@A@@"
"@A@@@@@@@B@@"
"@@H@@@@@@D@@"
"@@H@@@@@@H@@"
"@@D@@@@@A@@@"
"@@B@@@@@B@@@"
"@@A@@@@@D@@@"
"@@@H@@@@H@@@"
"@@@GOOOO@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@")
(RPAQ HAPPYHEADMAP (READBITMAP))
(43 53
"AOOOOOOOOON@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@AN@@@AN@B@"
"A@CO@@@CO@B@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@CO@@@CO@B@"
"A@AN@@@AN@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@H@@@@H@B@"
"A@@L@@@AH@B@"
"A@@F@@@C@@B@"
"A@@C@@@F@@B@"
"A@@AH@@L@@B@"
"A@@@G@GH@@B@"
"A@@@@OL@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"@OOOOOOOOOL@"
"@H@@@@@@@@D@"
"@D@@@@@@@@H@"
"@B@@@@@@@A@@"
"@A@@@@@@@B@@"
"@@H@@@@@@D@@"
"@@H@@@@@@H@@"
"@@D@@@@@A@@@"
"@@B@@@@@B@@@"
"@@A@@@@@D@@@"
"@@@H@@@@H@@@"
"@@@GOOOO@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@")
(RPAQ SADHEADMAP (READBITMAP))
(43 53
"AOOOOOOOOON@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@AN@@@AN@B@"
"A@CO@@@CO@B@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@GOH@@GOHB@"
"A@CO@@@CO@B@"
"A@AN@@@AN@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@OH@@@B@"
"A@@@G@G@@@B@"
"A@@AH@@L@@B@"
"A@@B@@@B@@B@"
"A@@D@@@A@@B@"
"A@@H@@@@H@B@"
"A@A@@@@@D@B@"
"A@B@@@@@B@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"A@@@@@@@@@B@"
"@OOOOOOOOOL@"
"@H@@@@@@@@D@"
"@D@@@@@@@@H@"
"@B@@@@@@@A@@"
"@A@@@@@@@B@@"
"@@H@@@@@@D@@"
"@@H@@@@@@H@@"
"@@D@@@@@A@@@"
"@@B@@@@@B@@@"
"@@A@@@@@D@@@"
"@@@H@@@@H@@@"
"@@@GOOOO@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@"
"@@@@@@@@@@@@")
(RPAQ DCURSORMAP (READBITMAP))
(16 16
"H@@C"
"L@@N"
"N@AL"
"G@C@"
"CHF@"
"ALL@"
"@OH@"
"@G@@"
"@OH@"
"AML@"
"CHN@"
"C@G@"
"F@CL"
"F@@O"
"L@@@"
"H@@@")
(RPAQ UCURSORMAP (READBITMAP))
(16 16
"@A@@"
"@CH@"
"@CH@"
"@GL@"
"@ON@"
"AOO@"
"@CH@"
"@CH@"
"@CH@"
"LCHC"
"LCHC"
"LCHC"
"LCHC"
"L@@C"
"OOOO"
"OOOO")
(RPAQ LCURSORMAP (READBITMAP))
(16 16
"@@GO"
"@@GO"
"@@@C"
"@D@C"
"@L@C"
"AL@C"
"GOOC"
"OOOC"
"GOOC"
"AL@C"
"@L@C"
"@D@C"
"@@@C"
"@@@C"
"@@GO"
"@@GO")
(RPAQ TCURSORMAP (READBITMAP))
(16 16
"OOOO"
"OOOO"
"L@@C"
"L@@C"
"LB@C"
"LCLC"
"LCOK"
"LCOA"
"LCNA"
"LCOA"
"LCCH"
"LBAL"
"L@@N"
"OH@G"
"OONC"
"@@@@")
(RPAQ SSCURSORMAP (READBITMAP))
(16 16
"NHIB"
"HHID"
"HHIH"
"HHID"
"HHIB"
"NNIB"
"@@@@"
"@@@@"
"HNNO"
"HHHD"
"HHHD"
"HNND"
"HHHD"
"HHHD"
"HHHD"
"NNHD")
(RPAQ AUTOCURSORMAP (READBITMAP))
(16 16
"@@@@"
"@@@@"
"@OH@"
"ABD@"
"BBB@"
"BBA@"
"EOON"
"H@@B"
"H@@A"
"H@@A"
"H@@A"
"K@AI"
"DONF"
"DHBD"
"DHBD"
"C@AH")
(PUTPROPS QA TRLIST (((0 2 X 1)
(Y 4 Y 1))
((0 2 0 1)
(1 3 Y -1)
(Y 2 Y 1))
((0 3 0 -1)
(X 1 X 1)
(Y 3 Y -1))
((Y 4 Y 1)
(%] 5 %] 1))
(NIL)))
(PUTPROPS QA TAPE (0 0 1 1 B B))
(PUTPROPS QQ TRLIST (((0 1 X R)
(Y 3 Y R))
((0 1 0 R)
(1 2 Y L)
(Y 1 Y R))
((0 2 0 L)
(X 0 X R)
(Y 2 Y L))
((Y 3 Y R)
(%] 4 %] R))
(NIL)))
(PUTPROPS T1 TRLIST (((0 2 X 1)
(Y 4 Y 1))
((0 2 0 1)
(1 3 Y -1)
(Y 2 Y 1))
((0 3 0 -1)
(X 1 X 1)
(Y 3 Y -1))
((Y 4 Y 1)
(%] 5 %] 1))
(NIL)))
(PUTPROPS T1 SYMBOLS (0 1 X Y %]))
(PUTPROPS 0n1n SYMBOLS (0 1 X Y %])
TRLIST (((0 2 X 1)
(Y 4 Y 1))
((0 2 0 1)
(1 3 Y -1)
(Y 2 Y 1))
((0 3 0 -1)
(X 1 X 1)
(Y 3 Y -1))
((Y 4 Y 1)
(%] 5 %] 1))
(NIL))
STATES (1 2 3 4 5)
INITIALSTATE 1
FINALSTATE 5
TAPE (0 0 1 1 %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]))
(PUTPROPS DEMO2 SYMBOLS (M I C H E L D N B R %])
TRLIST (((L 2 R 1)
(E 1 E 1)
(H 1 B 1)
(C 1 N 1)
(I 1 E 1)
(M 1 D 1)
(M 2 I 1))
NIL NIL NIL NIL NIL NIL NIL)
STATES (1 2)
INITIALSTATE 1
FINALSTATE 2
TAPE (M I C H E L %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %])
OBJLIST (MDLOGO XPD DB2 DB1 INPUT CCD PREP SC1 SC2 SC3 M1 M2 M3 M4 M5 TAP A1 A2 A3
A4 A5 A6 L.INPUT L.CCD L.RAW L.VIDEO L.PREPROCESS L.6BITS L.SCA
L.CRO L.SCR L.THR L.BIN L.VID L.COMP L.32BIT L.MEM L.AESS L.INTER
L.HEAD L.ENET L.IIT L.SCANS ENET.LINE L.TEXT TRAJ.TEXT TRAJ.CCD
TRAJ.RV TRAJ.PREP MM.6BITS TRAJ.SCA MM.BINVID TRAJ.32BIT MM.LUMP
L.END L.END2))
(PUTPROPS PONG SYMBOLS (A B C %])
TRLIST (((C 3 B 1)
(B 2 A 1)
(A 2 B 1))
((A 1 B -1)
(B 1 A -1))
NIL NIL NIL NIL NIL NIL NIL)
STATES (1 2 3)
INITIALSTATE 1
FINALSTATE 3
TAPE (A B C %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]
%] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %] %]))
(PUTPROPS TM COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2175 23009 (DELTRANS 2185 . 3152) (ENTERSTATES 3154 . 4284) (ENTERSYMS 4286 . 5354) (
EXISTINGSTATES 5356 . 6269) (EXISTINGSYMS 6271 . 6728) (EXISTINGTRANS 6730 . 7552) (ENTERTERMSTATES
7554 . 8214) (GETXY 8216 . 9355) (FINDAREA 9357 . 9550) (GETDIR 9552 . 9777) (GETSTATE 9779 . 9970) (
GETSYM 9972 . 10165) (GETTR 10167 . 10347) (MSELECT 10349 . 10806) (MAKEBOX 10808 . 11168) (MAKETAPE
11170 . 12023) (PRINTONTAPE 12025 . 12459) (GETTAPE 12461 . 13089) (MAKETRANS 13091 . 13611) (MARK
13613 . 13945) (MOVEHEAD 13947 . 14228) (PAINTOBJ 14230 . 14453) (PRINTDIR 14455 . 15069) (PRINTSTATE
15071 . 15417) (PRINTSYM 15419 . 15812) (SAVETAPE 15814 . 16011) (SHADEBOX 16013 . 16364) (TM 16366 .
18599) (TMCREATE 18601 . 19304) (MENUEXEC 19306 . 20209) (TMMOVE 20211 . 21643) (TMMOVEHEAD 21645 .
22353) (TMMSG 22355 . 22581) (UPDATETM 22583 . 23007)))))
STOP