-
Notifications
You must be signed in to change notification settings - Fork 7
/
Copy pathanimal.fs
153 lines (130 loc) · 4.2 KB
/
animal.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
\ animal 01.12.25 18:21 -- EJB
\ silly animal guessing game in which the computer
\ "learns" new animals as it goes.
\
\ written on 25 December 2001 by Edward J. Beroset
\ and released to the public domain by the author.
VARIABLE ROOT
CREATE MYPAD 80 ALLOT
\ adds a new node to the binary tree using
\ the passed string as the data
: NEWNODE ( c-addr u -- c-addr )
HERE >R \ save original address
0 , \ save YES node
0 , \ save NO node
DUP , \ save string length
HERE OVER ALLOT SWAP MOVE \ save string
R> ; \ return address of this node
\ returns the address of the left branch of
\ the passed node
: LEFT ( a-addr -- a-addr )
@ ;
\ returns the address of the right branch of
\ the passed node
: RIGHT ( a-addr -- a-addr )
CELL+ @ ;
\ given the address of a node, types the
\ text stored at that node.
: GETQ ( a-addr -- )
CELL+ CELL+ DUP @ SWAP CELL+ SWAP TYPE ;
\ returns TRUE if this is a terminal node.
: TERM? ( a-addr -- t )
DUP LEFT SWAP RIGHT OR 0= ;
\ prints the question based on the text
\ stored at this node.
: SHOWQ ( a-addr -- )
DUP TERM? IF \ is it a terminal node?
." Is it " GETQ ." ? "
ELSE
GETQ
THEN ;
\ returns TRUE if the passed char was y or Y
: YES? ( n -- t )
DUP [CHAR] Y = SWAP
[CHAR] y = OR ;
\ returns TRUE if the passed char was n or N
: NO? ( n -- t )
DUP [CHAR] N = SWAP
[CHAR] n = OR ;
\ returns the letter pressed by the user
\ and TRUE if that was either Y or N
: GETA ( -- n t )
MYPAD 1 ACCEPT DROP MYPAD C@
DUP DUP YES? SWAP NO? OR ;
\ asks a question based on the text at the
\ passed node and gets a response. The
\ letter returned is the users response and
\ the flag returned is TRUE if the user
\ wants to continue
: QUERY ( a-addr -- n t )
SHOWQ CR ." (Y, N or Q): "
GETA ;
\ learning consists of asking three questions. The questions
\ are: what was the animal? what's a question to differentiate?
\ and what is the answer to that question in the case of the new
\ animal? The first question causes a new terminal node to be
\ created. The second causes a new non-terminal node to be
\ created, and the last question allows the links to that
\ non-terminal to be set correctly.
: LEARN ( a-addr -- )
CR ." What is the animal you were thinking of?" CR
MYPAD DUP 80 ACCEPT NEWNODE ( -- oldtermaddr newnode )
CR ." What is a yes/no question that differentiates "
OVER @ GETQ ." from " DUP GETQ ." ?" CR
MYPAD DUP 80 ACCEPT NEWNODE ( -- oldtermaddr newnode qnode )
CR ." And what is the answer in the case of " OVER GETQ
." ?" GETA IF
YES? IF
DUP ROT ROT ! ( -- oldtermadd qnode )
2DUP CELL+ SWAP @ SWAP !
SWAP !
ELSE
DUP ROT ROT CELL+ ! ( -- oldtermadd qnode )
2DUP SWAP @ SWAP !
SWAP !
THEN
THEN ;
\ starts with the address of a variable which contains the
\ first structure. We do it this way so that the variable
\ can be modified when we learn a new animal.
: GUESS ( a-addr -- a-addr t )
DUP @ QUERY IF \ user wants to continue
OVER @ TERM? IF
YES? IF \ answer was Y
CR ." I guessed it!! Let's play again!" CR
DROP
ELSE \ answer was N
CR ." You stumped me!"
LEARN CR
THEN
ROOT
ELSE \ follow the answer to the next question
YES? IF
@
ELSE
@ CELL+
THEN
THEN
0 \ indicate that the user wants to continue
ELSE 1 \ indicate that the user wants to quit
THEN ;
\ seeds the binary tree with a single terminal node
: SEED ( -- )
S" a cow" NEWNODE ROOT ! ;
SEED
\ given a node address, this either prints
\ the text if it's a terminal node or replaces
\ the address with the addresses of the left
\ and right nodes.
: EXPAND ( a-addr -- a-addr a-addr | )
DUP TERM? IF
GETQ CR
ELSE
DUP LEFT SWAP RIGHT
THEN ;
\ lists the animals known to the game
: INVENTORY ( a-addr -- )
0 ROOT @ CR BEGIN EXPAND DUP 0= UNTIL DROP ;
\ plays the animal game
: ANIMAL
ROOT BEGIN CR CR GUESS UNTIL ;