Commit dfb01f06 authored by bp's avatar bp
Browse files

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
\ Enlightenment style 07feb98py
\needs get-imdata include Estyle.fs
\ E icons 14feb98py
widget class Eicon-pixmap
public:
cell var Eimage
cell var pixmap
cell var shape
method draw-at
how:
: init ( file len dpy -- ) bind dpy super init
(read-imicon Eimage !
3 3 3 3 Eimage @ Image border !+ !+ !+ !
$100 $100 $200 sp@ Eimage @ dpy xrc imdata @
ImlibSetImageModifier 2drop 2drop ;
: draw-at ( x y w h -- 0 0 w h x y w1 w2 )
over w @ <> over h @ <> or >r h ! w !
r> IF
pixmap @ ?dup IF
dpy xrc imdata @ ImlibFreePixmap drop
THEN
h @ w @ Eimage @ dpy xrc imdata @
ImlibRender drop
Eimage @ dpy xrc imdata @ ImlibMoveMaskToPixmap shape !
Eimage @ dpy xrc imdata @ ImlibMoveImageToPixmap pixmap !
4 dpy xrc set-function 0 dpy xrc set-color
1 0 0 h @ w @ 0 0 dpy drawable nip pixmap @ shape @
rot XCopyPlane drop
3 dpy xrc set-function
THEN
>r >r 0 0 w @ h @ r> r> shape @ pixmap @ ;
: draw xywh draw-at dpy mask ;
class;
: Eicon: ( "name" "file"<"> -- )
Create 0 , ," DOES> ( -- icon )
dup @ dup IF nip EXIT THEN drop
dup cell+ count screen self Eicon-pixmap new tuck swap ! ;
\ draw button 14feb98py
Eicon: button-f Estyle/ShinyMetal/bar_horizontal_2.png"
Eicon: button-d Estyle/ShinyMetal/bar_horizontal_1.png"
Eicon: button-p Estyle/ShinyMetal/bar_horizontal_3.png"
button implements
: e-draw ( x y w h icon -- )
Eicon-pixmap with draw-at endwith dpy mask ;
: e-button ( m -- ) >r xywh r> e-draw ;
: e-choise ( -- m )
color @ $FF and 1 =
IF push?
IF button-p
ELSE button-f THEN
ELSE push?
IF button-p
ELSE button-d THEN
THEN ;
: draw ( -- )
xywh defocuscol @ @ dpy box
e-choise e-button
text $@ 0 push? 1 and textcenter ;
class;
togglebutton implements
: draw ( -- )
xywh defocuscol @ @ dpy box
e-choise e-button
callback fetch
0= IF text $@ 0 push? 1 and textcenter
ELSE text1 $@ 2dup 0 textsize >r >r
xywh r> r> p- p2/ p+
push? dup p- color @ 8 >> dpy text THEN ;
class;
topindex implements
: e-draw-half ( x y w h icon -- )
Eicon-pixmap with 2* draw-at 4 pick 2/ 4 pin endwith
dpy mask ;
: e-button-half ( m y h -- )
{ m y h |
x @ y w @ h m e-draw-half } ;
: draw ( -- )
callback fetch color @ $18 >> negate
{ state o |
xywh state IF xS + THEN defocuscol @ @ dpy box
state 0= IF xywh rot + swap xS shadow drop dpy box THEN
e-choise y @ h @ xS +
state 0= IF xS -2 xS * p+ THEN e-button-half
text $@ state IF 0 o ELSE xS negate o xS + THEN
textcenter } ;
class;
boxchar implements
: draw ( -- )
xywh defocuscol @ @ dpy box
e-choise e-button
color 2+ 1 0 push? 1 and textcenter ;
button :: hglue
class;
togglechar implements
boxchar :: draw
boxchar :: hglue
class;
lbutton implements
: draw ( -- )
xywh defocuscol @ @ dpy box
e-choise e-button
text $@ h @ 2/ w @ 2/ min push? 1 and textleft ;
class;
\ toggle button
Eicon: tbutton-fl+ Estyle/ShinyMetal/button_kill_2.png"
Eicon: tbutton-fl- Estyle/ShinyMetal/button_off_2.png"
Eicon: tbutton-dl+ Estyle/ShinyMetal/button_kill_1.png"
Eicon: tbutton-dl- Estyle/ShinyMetal/button_off_1.png"
Eicon: tbutton-pl+ Estyle/ShinyMetal/button_kill_3.png"
Eicon: tbutton-pl- Estyle/ShinyMetal/button_off_3.png"
tbutton implements
: e-tchoise ( -- l+ l- ms r )
color @ $FF and 1 =
IF push?
IF tbutton-pl+ tbutton-pl- button-p
ELSE tbutton-fl+ tbutton-fl- button-f THEN
ELSE push?
IF tbutton-dl+ tbutton-dl- button-d
ELSE tbutton-dl+ tbutton-dl- button-d THEN
THEN ;
: e-tbutton ( l+ l- ms -- )
{ l+ l- ms |
xywh ms e-draw
x @ y @ h @ h @ xS xywh-
callback fetch IF l+ ELSE l- THEN e-draw } ;
: draw ( -- )
\ xywh defocuscol @ @ dpy box
e-tchoise e-tbutton
text $@ h @ w @ 2/ min 0 textleft ;
class;
ticonbutton implements
: draw ( -- )
xywh e-tchoise nip nip e-draw
x @ 1+ y @ 1+ h @ 2- callback fetch
IF icon+ h @ - 2/ + icon+ draw-at
ELSE icon- h @ - 2/ + icon- draw-at
THEN dpy mask
text $@
xN icon+ w @ icon- w @ max + 0 textleft ;
class;
Eicon: rbutton-fl+ Estyle/ShinyMetal/button_iconify_2.png"
Eicon: rbutton-fl- Estyle/ShinyMetal/button_off_2.png"
Eicon: rbutton-dl+ Estyle/ShinyMetal/button_iconify_1.png"
Eicon: rbutton-dl- Estyle/ShinyMetal/button_off_1.png"
Eicon: rbutton-pl+ Estyle/ShinyMetal/button_iconify_3.png"
Eicon: rbutton-pl- Estyle/ShinyMetal/button_off_3.png"
rbutton implements
: e-rchoise ( -- l+ l- ms r )
color @ $FF and 1 =
IF push?
IF rbutton-pl+ rbutton-pl- button-p
ELSE rbutton-fl+ rbutton-fl- button-f THEN
ELSE push?
IF rbutton-dl+ rbutton-dl- button-d
ELSE rbutton-dl+ rbutton-dl- button-d THEN
THEN ;
: e-rbutton ( l+ l- ms -- )
{ l+ l- ms |
xywh ms e-draw
x @ y @ h @ h @ xS xywh-
callback fetch IF l+ ELSE l- THEN e-draw } ;
: draw ( -- )
\ xywh defocuscol @ @ dpy box
e-rchoise e-rbutton
text $@ h @ w @ 2/ min 0 textleft ;
class;
\ text label
text-label implements
: draw ( -- )
xywh defocuscol @ @ dpy box
button-d e-button
text $@ h @ 2/ w @ textwh @ - 2/ min 0 textleft ;
button :: hglue
class;
icon-button implements
: draw ( -- )
xywh defocuscol @ @ dpy box
e-choise e-button
x @ xS + y @ h @ icon h @ - 2/ + push? dup p-
icon draw-at dpy mask
text $@
xS 1+ icon w @ + xN + push? 1 and textleft ;
class;
icon-but implements
: draw ( -- ) push? 1 and >r
xywh defocuscol @ @ dpy box
e-choise e-button
x @ w @ icon w @ - 2/ + r@ +
y @ h @ icon h @ - 2/ + r> +
icon draw-at dpy mask ;
: hglue icon w @ xS 2* + 1 *fil ;
: vglue icon h @ xS 2* + 1+ 1 *fil ;
class;
toggleicon implements
: draw ( -- )
callback fetch push? { s of |
xywh defocuscol @ @ dpy box
e-choise e-button
s IF icon+ w @ icon+ h @
ELSE icon- w @ icon- h @ THEN >r >r
x @ w @ r> - 2/ + y @ h @ r> - 2/ + of dup p-
s IF icon+ draw-at ELSE icon- draw-at THEN dpy mask } ;
: hglue icon+ w @ icon- w @ max xS 2* + 1+ 1 *fil ;
: vglue icon+ h @ icon- h @ max xS 2* + 1+ 1 *fil ;
class;
flipicon implements
: draw ( -- ) color push color @ $FFFFFF and
callback fetch IF -3 ELSE 2 THEN $18 << or color !
xywh defocuscol @ @ dpy box
e-choise e-button
callback fetch 1 and >r
x @ w @ icon w @ - 2/ + r@ +
y @ h @ icon h @ - 2/ + r> +
icon draw-at dpy mask ;
: hglue icon w @ xS 2* + 1+ 1 *fil ;
: vglue icon h @ xS 2* + 1+ 1 *fil ;
class;
Eicon: arrow-pt Estyle/ShinyMetal/button_arrow_up_3.png"
Eicon: arrow-ft Estyle/ShinyMetal/button_arrow_up_2.png"
Eicon: arrow-dt Estyle/ShinyMetal/button_arrow_up_1.png"
Eicon: arrow-pr Estyle/ShinyMetal/button_arrow_right_3.png"
Eicon: arrow-fr Estyle/ShinyMetal/button_arrow_right_2.png"
Eicon: arrow-dr Estyle/ShinyMetal/button_arrow_right_1.png"
Eicon: arrow-pb Estyle/ShinyMetal/button_arrow_down_3.png"
Eicon: arrow-fb Estyle/ShinyMetal/button_arrow_down_2.png"
Eicon: arrow-db Estyle/ShinyMetal/button_arrow_down_1.png"
Eicon: arrow-pl Estyle/ShinyMetal/button_arrow_left_3.png"
Eicon: arrow-fl Estyle/ShinyMetal/button_arrow_left_2.png"
Eicon: arrow-dl Estyle/ShinyMetal/button_arrow_left_1.png"
| Create tri-p-table T] arrow-pl arrow-pt arrow-pr arrow-pb [
| Create tri-f-table T] arrow-fl arrow-ft arrow-fr arrow-fb [
| Create tri-d-table T] arrow-dl arrow-dt arrow-dr arrow-db [
tributton implements
: draw ( -- ) xywh defocuscol @ @ dpy box
xywh color @ $FF and 1 =
IF push? IF tri-p-table ELSE tri-f-table THEN
ELSE tri-d-table THEN
color @ $E >> $C and + perform e-draw ;
: hglue xM xS 2* + 1 *fil ;
: vglue xM xS 2* + 1 *fil ;
class;
slidetri implements
| Create o-table 3 0 , , 0 3 , , -3 0 , , 0 -3 , ,
| Create p-table T] arrow-pl arrow-pt arrow-pr arrow-pb [
| Create f-table T] arrow-fl arrow-ft arrow-fr arrow-fb [
| Create d-table T] arrow-dl arrow-dt arrow-dr arrow-db [
: draw ( -- ) xywh defocuscol @ @ dpy box
xywh
color @ $FF and 1 =
IF push? IF p-table ELSE f-table THEN
ELSE d-table THEN
color @ $E >> $C and + perform e-draw ;
: hglue tributton :: hglue drop 0 ;
: vglue tributton :: vglue drop 0 ;
class;
\ slider
Eicon: hslider-d Estyle/ShinyMetal/bar_amber_horizontal_1.png"
Eicon: hslider-f Estyle/ShinyMetal/bar_amber_horizontal_2.png"
Eicon: hslider-p Estyle/ShinyMetal/bar_horizontal_3.png"
Eicon: vslider-d Estyle/ShinyMetal/bar_amber_vertical_1.png"
Eicon: vslider-f Estyle/ShinyMetal/bar_amber_vertical_2.png"
Eicon: vslider-p Estyle/ShinyMetal/bar_vertical_3.png"
arule class Erule
public: 2 cells var Estretch
how:
: init ( actor hxt vxt iconf icond -- )
Estretch 2! super init ;
: draw ( -- )
xywh Estretch 2@
color @ $FF and 1 <> IF swap THEN drop
Eicon-pixmap with draw-at endwith dpy mask ;
class;
arule class Eside
public: cell var Eicons
how:
: focus 1 color c! draw ;
: defocus 0 color c! draw ;
: init ( actor hxt vxt icon -- )
Eicons ! super init ;
: e-draw ( x y w h icon -- )
Eicon-pixmap with draw-at endwith dpy mask ;
: ep-draw ( x y w h icon -- ) >r parent xywh
r> Eicon-pixmap with draw-at endwith
>r >r 2drop 2drop 2drop { x y w h |
x y parent xywh 2drop p- w h x y } r> r>
dpy mask ;
: draw ( -- )
xywh Eicons @ ep-draw ;
class;
hslider implements
: init ( callback -- ) >callback
^ R[ lstep ]R 0 slidetri new
^ R[ lpage ]R ['] part1 ['] part0 hslider-p Eside new
^ M[ slide ]M ['] part2 ['] part0 hslider-f hslider-d Erule new
arule with $01000003 assign ^ endwith
^ R[ rpage ]R ['] part3 ['] part0 hslider-p Eside new
^ R[ rstep ]R 2 slidetri new
5 super init ;
class;
hslider0 implements
hslider :: init
class;
hscaler implements
: init ( callback -- ) >callback
^ M[ slide ]M ['] part0a ['] part5 arule new
^ R[ lpage ]R ['] part1 ['] part0b hslider-p Eside new
^ M[ slide ]M :[ part4 swap 2* xS + swap ]:
:[ part0a swap xS 2* + swap ]:
hslider-f hslider-d Erule new
arule with $01000003 assign ^ endwith
^ R[ rpage ]R ['] part3 ['] part0b hslider-p Eside new
3 hbox new
2 vbox new 1 super super init ;
class;
vscaler implements
: init ( callback -- ) >callback
^ M[ slide ]M ['] part5 ['] part0a arule new
^ R[ rpage ]R ['] part0b ['] part3 vslider-p Eside new
^ M[ slide ]M :[ part0a swap xS 2* + swap ]:
:[ part4 swap 2* xS + swap ]:
vslider-f vslider-d Erule new
arule with $01000003 assign ^ endwith
^ R[ lpage ]R ['] part0b ['] part1 vslider-p Eside new
3 vbox new
2 hbox new 1 super super init ;
class;
vslider implements
: init ( callback -- ) >callback
^ R[ lstep ]R 1 slidetri new \ 1 ^ habox new fixbox
^ R[ lpage ]R ['] part0 ['] part1 vslider-p Eside new
^ M[ slide ]M ['] part0 ['] part2 vslider-f vslider-d Erule new
arule with $02000003 assign ^ endwith
^ R[ rpage ]R ['] part0 ['] part3 vslider-p Eside new
^ R[ rstep ]R 3 slidetri new \ 1 ^ habox new fixbox
5 super init ;
class;
vslider0 implements
vslider :: init
class;
Eicon: vbutton-f Estyle/ShinyMetal/bar_vertical_2.png"
Eicon: vbutton-d Estyle/ShinyMetal/bar_vertical_1.png"
Eicon: vbutton-p Estyle/ShinyMetal/bar_vertical_3.png"
vrtsizer implements
: draw ( -- ) xywh defocuscol @ @ dpy box
e-choise e-button ;
class;
vsizer implements
vrtsizer :: draw
class;
vxrtsizer implements
vrtsizer :: draw
class;
hrtsizer implements
: he-choise ( -- m )
color @ $FF and 1 =
IF push?
IF vbutton-p
ELSE vbutton-f THEN
ELSE push?
IF vbutton-p
ELSE vbutton-d THEN
THEN ;
: draw ( -- ) xywh defocuscol @ @ dpy box
he-choise e-button ;
class;
hsizer implements
hrtsizer :: draw
class;
hxrtsizer implements
hrtsizer :: draw
class;
menu-entry implements
: draw ( -- ) push? >r
r@ 1 and
IF button-f e-button
ELSE xywh color @ dpy box THEN
text $@ xM r> 2 = 1 and textleft ;
class;
menu-title implements
: draw ( -- )
color 2+ c@
IF button-f e-button
ELSE xywh color @ dpy box THEN
text $@ 0 0 textcenter ;
class;
sub-menu implements
: draw ( -- ) push? >r
r@ 1 and color 2+ c@ or
IF button-f e-button
ELSE xywh color @ dpy box THEN
text $@ xM r> 2 = 1 and textleft
xM xS 2* + >r
x @ w @ + r@ - y @ h @ r@ - 2/ + r> dup
color $FF and 1 =
IF push? IF tri-p-table ELSE tri-f-table THEN
ELSE tri-d-table THEN 2 cells + perform e-draw ;
class;
previous previous previous previous previous previous Forth
\ Enlightenment style 07feb98py
\needs get-imdata include Estyle.fs
\ E icons 14feb98py
widget class Eicon-pixmap