Commit dfb01f06 authored by bp's avatar bp

checkin bigforth


git-svn-id: https://forth-ev.de/repos/bigforth@205 3b8d8251-53f3-0310-8f3b-fd1cb8370982
parent 598825e9
This diff is collapsed.
#! /usr/local/bin/bigforth
\ four in a row game
6 Value #rows
7 Value #cols
4 Value #win
#rows 2 + Value *rows
#cols 2 + Value *cols
8 Value #depth
\ board data base
Create board here *rows *cols * dup allot erase
\ board operations: push stone and display result
[IFUNDEF] cx@ : cx@ ( addr -- c ) c@ dup $80 and negate or ; [THEN]
: b[] ( x y -- board[x,y] )
*rows * + [ board *rows 1+ + ] ALiteral + ;
: .board ( -- ) cr ." -0123456"
#rows 0 ?DO cr I 0 .r #cols 0 ?DO
J I b[] cx@ 1 min -1 max 1+
s" x.o" drop + c@ emit LOOP LOOP ;
Variable cur-stone
: seeker DOES> @ ( addr index -- n )
over #win 0 ?DO over + dup cx@ cur-stone @ * 0<= ?LEAVE LOOP
swap >r - negate r> / 1- ;
: seek ( n -- ) Create dup , seeker Create negate , seeker ;
1 seek >left >right
*rows seek >up >down
*rows 1- seek >lu >rd
*rows 1+ seek >ld >ru
: score? ( boardp -- score-addr )
>r
r@ >left r@ >right +
r@ >up r@ >down + max
r@ >lu r@ >rd + max
r@ >ld r@ >ru + max 1+ cur-stone @ *
r@ c! r> ;
: stone ( side col -- score-addr ) over cur-stone !
0 swap b[] #rows 0 skip drop 1- tuck c! score? ;
Variable gameover gameover on
: stone? ( n col -- ) stone cx@ abs #win >= gameover ! ;
\ alpha-beta min-max strategy
Variable side -1 side !
: <stone ( score-addr ) 0 swap c! ; [IFDEF] macro macro [THEN]
: /side side @ negate side ! ; [IFDEF] macro macro [THEN]
\ count all square scores with the same sign
: leaf-score ( -- score )
0 0 board *rows *cols * bounds ?DO
I cx@ dup 0>= IF dup * + ELSE swap >r dup * + r> THEN
LOOP side @ 0< IF swap THEN over swap - * 8* 7 random + ;
\ alpha-beta-min-max: Same evaluation for both sides;
\ just negate the score of the other side
\ start with minimal possible score; leave with maximal score if you win
\ otherwise check score of next half-move
\ leave if better than beta
\ update alpha if current score is less
$7FFFFFFF Constant <best>
<best> negate Constant <worst>
<best> 1- Constant <win>
<win> negate Constant <lost>
<best> 2/ 1+ Constant <half-best>
Create min-max# $20 cells allot
: eval-min-max ( beta n -- score best )
1 over cells min-max# + +!
dup 0= IF 2drop leaf-score 0 EXIT THEN
/side -1 <worst> ( beta n best alpha )
#cols 0 ?DO
0 I b[] cx@ 0= IF
side @ I stone >r
r@ cx@ abs #win >= IF
r> <stone 2drop I <win> LEAVE THEN
2over 1- swap >r over negate swap recurse drop
dup <half-best> / - negate r> r> <stone
\ beta n best alpha score beta
\ if score better than beta, we are done
2dup > IF drop nip nip I swap LEAVE THEN drop
\ if score better than alpha, new score is best one
2dup < IF nip nip I swap ELSE drop THEN
THEN
LOOP swap 2swap 2drop /side ;
: c ( -- score best ) min-max# $20 cells erase
-1 side ! <best> #depth eval-min-max
\ min-max# #depth 1+ cells bounds ?DO I ? cell +LOOP space dup . cr
1 over stone? ;
: 4init gameover off board *rows *cols * erase ;
: h ( n -- ) gameover @ IF 4init cr ." New game" THEN
dup #cols 0 within abort" sorry, outside the field"
0 over b[] cx@ abort" sorry, column already full"
-1 swap stone? gameover @ 0= IF
c drop <lost> #depth + <= IF ." I'm going to lose"
ELSE gameover @ IF ." I win" THEN THEN
ELSE ." you win" THEN
true #cols 0 ?DO 0 I b[] cx@ 0<> and LOOP
IF ." tie" gameover on THEN .board ;
#! ./bigforth float.fb
\ Challenge 1 17-8-2001jps
float vocabulary chall also chall definitions
32 constant symb-sz create symb-tb symb-sz 81 * allot
: new-symb symb-sz symb-tb +! source >in @ tuck - >r +
symb-tb dup @ + r@ over c! 1+ r> move ;
18 cells constant gv-sz create gv-tb gv-sz allot
: gv: dup constant cell+ ;
gv-tb gv: notme gv: score gv: drop
: myturn false notme ! ; : theirturn true notme ! ;
\ Challenge 2 17-8-2001jps
: mk-mv ( s# ) drop ;
: best.0 ( - s# c" ) symb-tb dup @ 32 / random 1+ 32 * tuck + ;
: @score ( <f> ) bl parse >float f>s score +! ;
: reset 0 symb-tb ! gv-tb gv-sz erase theirturn ;
\ Challenge Final 17-8-2001jps
: getstr ( a n - m ) over + >r dup
begin key dup 10 <> over 13 <> and
while over c! 1+ dup r@ > until r@ then r> 2drop swap - ;
vocabulary commands vocabulary symbols
: @command commands definitions ; : @input ;
: >ps symbols definitions ; create my-ibuff 255 allot
: str1 s" marker clean : new clean str1 evaluate reset ; >ps" ;
: prog str1 evaluate reset ." @info name MyPlayer" cr
begin my-ibuff dup 255 accept dup
if over c@ 35 <> if evaluate then else 2drop then again ;
also commands definitions
: exit ." @info exit" cr bye ;
: symbol >ps new-symb create symb-tb @ , does> @ mk-mv ;
: play >ps myturn best.0 count type cr mk-mv theirturn ;
prog
This diff is collapsed.
This diff is collapsed.
\ Enlightenment style 14feb01py
\ This style uses Imlib 14feb01py
\needs imlib include imlib.fs
\needs xconst | import xconst
also DOS also Memory also imlib also xconst also X11 also MINOS also
: get-imdata ( dpy -- imdata )
dup ImlibInit >r
dup DefaultScreen DefaultDepth
dup 24 >= IF drop 4 ELSE
15 < IF \ 0" colors.rgb" r@ ImlibLoadColors drop
3 ELSE 5 THEN THEN
r@ ImlibSetRenderType drop r> ;
xresource implements
: open ( string -- )
XOpenDisplay dup dpy ! get-imdata imdata ! ;
\ There should be a close method, but there
\ is no such thing in Imlib
class;
screen xrc dpy @ get-imdata screen xrc imdata !
\ read icons with imlib 14feb98py
\ make a awful pink the default background
| Create bgcol struct ImColor allot
$FE bgcol ImColor r !
$00 bgcol ImColor g !
$FF bgcol ImColor b !
: (read-imicon ( addr u -- image )
2dup s" .icn" suffix? IF read-icn pause EXIT THEN
dup 1+ NewPtr dup >r place r@ c>0"
r@ >path.file
screen xrc imdata @ ImlibLoadImage
bgcol over Image shape_color sizeof ImColor move
r> DisposPtr ;
: >pswh ( image --- pixmap1 pixmap2 w h ) >r
r@ Image pixmap @
r@ Image shape_mask @
r@ Image width @
r> Image height @ ;
: read-imicon (read-imicon >pswh ;
\ ' read-imicon IS read-icon
# bigforth makefile
DATE= $$(date '+%d%b%Y' | tr '[A-Z]' '[a-z]')
SRCREV=2.1.3
MINOSREV=1.1.3
BINREV=$(SRCREV)
PATREV=1.0.1
EWOODREV=1.0.2
ESHMREV=1.0.2
DOCREV=obsolete
package =
prefix = $(package)@prefix@
TEXI2DVI = texi2dvi
DVI2PS = dvips -Z
TEXI2HTML = texi2html
MAKEINFO = makeinfo
INSTDIR = $(prefix)/lib/bigforth
BININSTDIR = $(prefix)/bin
CC = @CC@ @ARCHFLAGS@
CP = cp
MV = mv
EXE = @EXEEXT@
CFLAGS = -g -O2 -Wall -DVERSION_DATE='"'"$(DATE)"'"' -DINSTDIR='"'"$(INSTDIR)"'"' @EXTFLAGS@
LDLIBS = @LIBS@
SHELL = /bin/sh
LIB = $$(if [ "$$(ldd bigforth | grep libc | cut -f2 | cut -f1 -d' ')" = libc.so.5 ]; then echo -n libc5; else echo -n glibc; fi)
LIBDIST = $$(if [ "$$(ldd bigforth/bigforth | grep libc | cut -f2 | cut -f1 -d' ')" = libc.so.5 ]; then echo -n libc5; else echo -n glibc; fi)
WARNING =
#WARNING = warning on
BYE = cr bye
SAVE = ' .blk is .status warning on savesystem
XSAVE = warning on savesystem
OBJS = bigforth.o xbigforth.o linker.o
SOURCE = bigforth.c linker.S
KERNSRC = forth.fb target.fb
SYSSRC = assem486.fb stream.fb errore.fs hash.fs fileint.fb \
strings.fs savemod.fb tasker.fb vt100key.fs disass.fb \
tools.fb except.fs sedit.fb struct.fs lambda.fs idle.fs \
startup.fb ftast.fb environ.fs version.h minos-version.h
XCSRC = x.fs glconst.fs
XSRC = startx.fb minos.fb oof.fb x11.fs xpm.fs locals.fs edit.fb \
ediwind.fs edit.fs opengl.fs xstyle.fs status.fb \
pipes.fb ptty.fs login.fs pixmap.fs png.fs browser.fs \
points.fs qsort.fs string.fs sincos.fs utf-8.fs xrender.fs \
xbigforth.cnf xft-font.fs imlib.fs Estyle.fs
all: bigforth$(EXE) forthker$(EXE) xbigforth$(EXE) xbigforth.fi
version.h: Makefile.in
echo '"'$(SRCREV)'"' >$@
minos-version.h: Makefile.in
echo '"'$(MINOSREV)'"' >$@
%.o: %.c version.h
$(CC) $(CFLAGS) -c $<
xbigforth.o: bigforth.c version.h minos-version.h
$(CC) $(CFLAGS) -DMINOS -c $< -o $@
%.o: %.S
$(CC) -c $<
bigforth$(EXE): bigforth.o linker.o
$(CC) $(CFLAGS) bigforth.o linker.o $(LDLIBS) -o bigforth
strip bigforth$(EXE)
forthker$(EXE): bigforth$(EXE)
$(CP) $< $@
xbigforth$(EXE): xbigforth.o linker.o
$(CC) $(CFLAGS) @WINDOWS@ xbigforth.o linker.o $(LDLIBS) -o $@
strip $@
scr2str$(EXE) str2scr$(EXE): scr2str.c
$(CC) $(CFLAGS) $< -o scr2str$(EXE)
ln -s scr2str$(EXE) str2scr$(EXE)
forthker.fi: $(KERNSRC)
-@$(MV) $@ $@~
./bigforth -e ": $(LIB) ; include forth.fb save-target forthker $(BYE)"
bigforth.fi: forthker.fi $(SYSSRC)
-@$(MV) $@ $@~
./forthker -e "$(WARNING) include startup.fb $(SAVE) bigforth $(BYE)"
xbigforth.fi: bigforth.fi xconst.fm glconst.fm float.fm $(XSRC) bigforth.cnf
-@$(MV) $@ $@~
./bigforth -e "$(WARNING) use x.fs use glconst.fs use float.fb include startx.fb $(XSAVE) xbigforth $(BYE)"
xconst.fm: $(XCSRC) forthker.fi $(SYSSRC)
-@$(MV) $@ $@~
./bigforth -e "$(WARNING) include x.fs m' xconst savemod xconst $(BYE)"
glconst.fm: $(XCSRC) forthker.fi $(SYSSRC)
-@$(MV) $@ $@~
./bigforth -e "$(WARNING) use x.fs include glconst.fs m' glconst savemod glconst $(BYE)"
float.fm: float.fb forthker.fi $(SYSSRC)
-@$(MV) $@ $@~
./bigforth -e "$(WARNING) use x.fs use glconst.fs include float.fb m' float savemod float $(BYE)"
CPYDIST = bigforth/{README,COPYING,CREDITS}
DOSDIST = bigforth/{forthker,bigforth,xbigforth}$(EXE) bigforth/{forthker,bigforth}.fi bigforth/{version.h,minos-version.h}
DOCDIST = bigforth/help/{*.html,[a-z]*.gif,*.jpg,*.sh} bigforth/doc/bigforth.texi
ICONDIST = bigforth/icons/*.png bigforth/icons/minos1+.icn $(DRAGONDIST)
SRCDIST = bigforth/{BUGS,ToDo,config.guess,config.sub,install-sh,{Makefile,configure,{,x}bigforth.cnf}{,.in},[^E]*.f[sb],Estyle.fs,*.m,*.c,*.S,iss.sh,tips.txt,forthker.fi,xpmtoicn} $(ICONDIST)
DRAGONDIST = bigforth/pattern/dragon{,-head,-wing,-claw}.png \
bigforth/pattern/{bark,normal-w1,back,focus}.ppm
PATDIST = bigforth/pattern/{back,backtext,dark,focus,light,normal}{-c,-h,-p,-w,-w1,-m,-d,}.ppm \
EDIST1 = bigforth/Estyle/wood/{Makefile,*.inc} \
bigforth/Estyle/wood/{button,arrow,[hv]slider,[rt]button}-[dfps][blmrt]*.{pov,png} bigforth/Estyle-wood.fs
EDIST2 = bigforth/Estyle/ShinyMetal/* bigforth/Estyle-ShinyMetal.fs
COMPRESS = j
COMPSUB = .bz2
TAR = tar -$(COMPRESS)chf
#COMPRESS = z
#COMPSUB = .gz
docdist: all
cd ..; $(TAR) bigforth/bigforth-doc-"$(DOCREV)".tar$(COMPSUB) $(DOCDIST)
srcdist:
cd ..; $(TAR) bigforth/bigforth-"$(SRCREV)".tar$(COMPSUB) $(SRCDIST) $(CPYDIST)
patdist: all
cd ..; $(TAR) bigforth/bigforth-pattern-"$(PATREV)".tar$(COMPSUB) $(PATDIST)
edist1: all
cd ..; $(TAR) bigforth/bigforth-edata-wood-"$(EWOODREV)".tar$(COMPSUB) $(EDIST1)
edist2: all
cd ..; $(TAR) bigforth/bigforth-edata-ShinyMetal-"$(ESHMREV)".tar$(COMPSUB) $(EDIST2)
dist: all docdist srcdist patdist edist1 edist2
dist-files:
@echo $(SRCDIST) $(DOCDIST) $(CPYDIST) $(DOSDIST)
INSTDIRS = pattern icons help src Estyle Estyle/wood Estyle/ShinyMetal
install: all
@install -d $(BININSTDIR)
@install -d $(INSTDIR)
@for i in $(INSTDIRS); do install -d $(INSTDIR)/$$i; done
@install -m 644 {forthker,bigforth,xbigforth}.fi {float,glconst,xconst}.fm $(INSTDIR)
@install -m 644 {bigforth,xbigforth}.cnf $(INSTDIR)
@install -m 755 {forthker,bigforth,xbigforth} $(BININSTDIR)
@install -m 644 {BUGS,ToDo,README,COPYING,CREDITS,Makefile,*.f[sb],*.m,*.c,*.S,iss.sh,tips.txt} $(INSTDIR)/src
@install -m 644 icons/*.png $(INSTDIR)/icons
@install -m 644 pattern/dragon{,-claw,-head,-wing}.png pattern/bark.ppm $(INSTDIR)/pattern
@if [ -d help ]; then install -m 644 help/{*.html,[a-z]*.gif,*.jpg,*.sh} $(INSTDIR)/help; fi
@if [ -f pattern/back-p.ppm ]; then install -m 644 pattern/{back,backtext,dark,focus,light,normal}{-c,-h,-p,-w,-w1,-m,-d,}.ppm pattern/dragon.ppm $(INSTDIR)/pattern; fi
@if [ -d Estyle/wood ]; then install -m 644 Estyle/wood/{button,arrow,[hv]slider,[rt]button}-[dfps][blmrt]*.png $(INSTDIR)/Estyle/wood; fi
@if [ -d Estyle/ShinyMetal ]; then install -m 644 Estyle/ShinyMetal/* $(INSTDIR)/Estyle/ShinyMetal; fi
configure: configure.in
autoconf
config.status: configure
if [ -f config.status ]; \
then ./config.status --recheck; \
else ./configure; fi
Makefile: Makefile.in config.status
CONFIG_FILES="$@" ./config.status
xbigforth.cnf: xbigforth.cnf.in config.status
CONFIG_FILES="$@" ./config.status
bigforth.cnf: bigforth.cnf.in config.status
CONFIG_FILES="$@" ./config.status
# This is the documentation part, and is not ready yet
doc/bigforth.dvi doc/bigforth.fns: bigforth.texi
cd doc; $(TEXI2DVI) bigforth.texi
doc/bigforth.ps: doc/bigforth.dvi
$(DVI2PS) doc/bigforth.dvi -o $@
doc/bigforth.info doc/bigforth.info-*: bigforth.texi
-cd doc; $(MAKEINFO) bigforth.texi
doc/bigforth.txt: bigforth.texi
-cd doc; $(MAKEINFO) --no-headers --no-split bigforth.texi >bigforth.txt
info: doc/bigforth.info
ps: doc/bigforth.ps
html: doc/bigforth.texi
-$(RMTREE) html
-mkdir html
cd html; $(TEXI2HTML) -menu -split_node ../doc/bigforth.texi
doc: doc/bigforth.ps html doc/bigforth.txt
# make debian
bigforth.deb: all
-rm -rf debian
mkdir debian
make package=debian install
(cd debian; find * -name '*' -exec md5sum '{}' ';') >md5sums
echo "Package: bigforth" >control
echo "Version: $(SRCREV)" >>control
echo "Section: programming" >>control
echo "Priority: optional" >>control
echo "Architecture: i386" >>control
echo "Maintainer: Bernd Paysan <bernd.paysan@gmx.de>" >>control
echo "Description: bigFORTH+MINOS" >>control
echo " bigFORTH is a native code Forth. It is available for Linux and" >>control
echo " Windows 95/98/NT under GPL. The most striking feature is the" >>control
echo " graphical user interface MINOS (GUI in Forth) and the form editor" >>control
echo " Theseus (Theseus is still beta)." >>control
mkdir debian/DEBIAN
cp control debian/DEBIAN
cp md5sums debian/DEBIAN
dpkg-deb --build debian
mv debian.deb bigforth_$(SRCREV)_i386.deb
rm -rf control md5sums debian
Create XNRequiredCharSet ,0" requiredCharSet"
Create XNQueryOrientation ,0" queryOrientation"
Create XNBaseFontName ,0" baseFontName"
Create XNOMAutomatic ,0" omAutomatic"
Create XNMissingCharSet ,0" missingCharSet"
Create XNDefaultString ,0" defaultString"
Create XNOrientation ,0" orientation"
Create XNDirectionalDependentDrawing ,0" directionalDependentDrawing"
Create XNContextualDrawing ,0" contextualDrawing"
Create XNFontInfo ,0" fontInfo"
Create XNVaNestedList ,0" XNVaNestedList"
Create XNQueryInputStyle ,0" queryInputStyle"
Create XNClientWindow ,0" clientWindow"
Create XNInputStyle ,0" inputStyle"
Create XNFocusWindow ,0" focusWindow"
Create XNResourceName ,0" resourceName"
Create XNResourceClass ,0" resourceClass"
Create XNGeometryCallback ,0" geometryCallback"
Create XNDestroyCallback ,0" destroyCallback"
Create XNFilterEvents ,0" filterEvents"
Create XNPreeditStartCallback ,0" preeditStartCallback"
Create XNPreeditDoneCallback ,0" preeditDoneCallback"
Create XNPreeditDrawCallback ,0" preeditDrawCallback"
Create XNPreeditCaretCallback ,0" preeditCaretCallback"
Create XNPreeditStateNotifyCallback ,0" preeditStateNotifyCallback"
Create XNPreeditAttributes ,0" preeditAttributes"
Create XNStatusStartCallback ,0" statusStartCallback"
Create XNStatusDoneCallback ,0" statusDoneCallback"
Create XNStatusDrawCallback ,0" statusDrawCallback"
Create XNStatusAttributes ,0" statusAttributes"
Create XNArea ,0" area"
Create XNAreaNeeded ,0" areaNeeded"
Create XNSpotLocation ,0" spotLocation"
Create XNColormap ,0" colorMap"
Create XNStdColormap ,0" stdColorMap"
Create XNForeground ,0" foreground"
Create XNBackground ,0" background"
Create XNBackgroundPixmap ,0" backgroundPixmap"
Create XNFontSet ,0" fontSet"
Create XNLineSpace ,0" lineSpace"
Create XNCursor ,0" cursor"
Create XNQueryIMValuesList ,0" queryIMValuesList"
Create XNQueryICValuesList ,0" queryICValuesList"
Create XNVisiblePosition ,0" visiblePosition"
Create XNR6PreeditCallback ,0" r6PreeditCallback"
Create XNStringConversionCallback ,0" stringConversionCallback"
Create XNStringConversion ,0" stringConversion"
Create XNResetState ,0" resetState"
Create XNHotKey ,0" hotKey"
Create XNHotKeyState ,0" hotKeyState"
Create XNPreeditState ,0" preeditState"
Create XNSeparatorofNestedList ,0" separatorofNestedList"
\ adjust pathes 22jun98py
include fileop.fb
DOS also fileop also minos also
: adjust-path-id ( addr-id u1 addr-path u2 addr-file u3 -- )
2dup r/w open-file throw >r
s" tmp.cnf" r/w output-file
BEGIN scratch $100 r@ read-line throw WHILE
scratch over 5 min s" Path " compare 0=
IF drop .' Path "'
pathsep emit 2over type '" emit
ELSE scratch over dup 7 - /string s" date-id" compare
0= IF drop >r >r
.' s" ' 2over type .' " date-id'
r> r>
ELSE scratch swap type THEN
THEN cr
REPEAT drop eot r> close-file throw
s" tmp.cnf" 2swap cp 0" tmp.cnf" fdelete drop 2drop 2drop ;
\ 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 ;
<