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

3d-turtle.fs

0 → 100644
+1156 −0

File added.

Preview size limit exceeded, changes collapsed.

4wins.fs

0 → 100755
+118 −0
Original line number Diff line number Diff line 
#! /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 ;

Chall.0.fs

0 → 100755
+39 −0
Original line number Diff line number Diff line 
#! ./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

Estyle-ShinyMetal.fs

0 → 100644
+449 −0
Original line number Diff line number Diff line 
\ 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

Estyle-wood.fs

0 → 100644
+534 −0

File added.

Preview size limit exceeded, changes collapsed.