Author: wmb Date: 2007-09-19 11:52:41 +0200 (Wed, 19 Sep 2007) New Revision: 626
Modified: cpu/x86/pc/olpc/fw.bth cpu/x86/pc/olpc/life.fth Log: Life performance improvements.
Modified: cpu/x86/pc/olpc/fw.bth =================================================================== --- cpu/x86/pc/olpc/fw.bth 2007-09-19 05:35:55 UTC (rev 625) +++ cpu/x86/pc/olpc/fw.bth 2007-09-19 09:52:41 UTC (rev 626) @@ -500,7 +500,7 @@ ; : ?games ( -- ) game-key-mask h# 20 and if - time&date 5drop 1 and if pong else d# 1200 life then + time&date 5drop 1 and if pong else life-demo then then ; : open-keyboard ( -- )
Modified: cpu/x86/pc/olpc/life.fth =================================================================== --- cpu/x86/pc/olpc/life.fth 2007-09-19 05:35:55 UTC (rev 625) +++ cpu/x86/pc/olpc/life.fth 2007-09-19 09:52:41 UTC (rev 626) @@ -1,7 +1,7 @@
\ rgb color value -h# ff 0 0 rgb>565 constant xred \ red -h# 0 0 0 rgb>565 constant xblack \ black +h# ff ff 0 rgb>565 constant lf_fg \ yellow +h# 0 0 0 rgb>565 constant lf_bg \ black
\ screen size constant d# 128 constant lf_width @@ -18,13 +18,13 @@ : >work ( i j -- adr ) swap lf_width * + lf_board_work + ;
: show-cell ( state y x -- ) - >offset swap if xred else xblack then show-state + >offset swap if lf_fg else lf_bg then show-state ;
\ display the board of life : lf_board_print ( -- ) - lf_height 0 do - lf_width 0 do + lf_height 1- 1 do + lf_width 1- 1 do j i >cell c@ j i show-cell loop loop @@ -35,12 +35,29 @@
: xy+ ( x1 y1 x2 y2 -- x3 y3 ) rot + -rot + swap ;
+code sumcell ( adr -- sum ) + bx pop + ax ax xor + lf_width negate [bx] al add + lf_width 1- negate [bx] al add + lf_width 1+ negate [bx] al add + -1 [bx] al add + 1 [bx] al add + lf_width [bx] al add + lf_width 1- [bx] al add + lf_width 1+ [bx] al add + + ax push +c; + + : +sum ( i j +i +j -- i j ) 2over xy+ ( i j i' j' ) >cell c@ cell-sum +! ( i j ) ;
: lf_check_live_i_j ( i j -- ncell ) +[ifdef] notdef cell-sum off ( i j ) -1 -1 +sum -1 0 +sum @@ -51,6 +68,9 @@ 1 0 +sum 1 1 +sum ( i j ) 2drop cell-sum @ ( sum ) +[else] + >offset lf_board + sumcell +[then] ;
\ one step evolve the board @@ -61,132 +81,151 @@ lf_board lf_width + lf_board lf_width lf_height 1 - * + lf_width move
\ copy the column before last to the first one and the second to the last - lf_height 0 do - i lf_width 2 - >cell @ i 0 >cell c! - i 1 >cell @ i lf_width 1 - >cell c! + lf_board ( adr ) + lf_height 0 do ( adr ) + dup lf_width + ( adr end-adr ) + over 1+ c@ over 1- c! ( adr end-adr ) + tuck 2- c@ swap c! ( end-adr ) loop + drop
- lf_height 1 - 1 do - lf_width 1 - 1 do - j i lf_check_live_i_j ( sum1 ) - j i >cell c@ if ( sum1 ) + 0 ( row-offset ) + lf_height 1- 1 do ( row-offset ) + lf_width + ( row-offset ) + dup 1+ lf_width 2- bounds do ( row-offset ) + i lf_board + dup sumcell ( row adr sum1 ) + swap c@ if ( row sum1 ) \ caso in cui nella cella c'e' 1 - 2 3 between ( 0|-1 ) - else ( sum1 ) + 2 3 between ( row 0|-1 ) + dup 0= if i lf_bg show-state then + else ( row sum1 ) \ caso in cui nella cella c'e' 0 - 3 = ( 0|-1 ) - then - negate ( 0|1 ) - dup j i >work c! ( 0|1 ) - dup j i >cell c@ <> if ( 0|1 ) - j i show-cell - else - drop - then - loop + 3 = ( row 0|-1 ) + dup if i lf_fg show-state then + then ( row 0|-1 ) + negate ( row 0|1 ) + i lf_board_work + c! ( row 0|1 ) + loop ( row ) loop + drop +[then] lf_board_work lf_board /board move ;
-decimal -\ initialize data -: set-cell ( i j -- ) >cell 1 swap c! ; -: init-board ( -- ) - lf_board /board erase -[ifdef] notdef - 2 2 set-cell - 3 3 set-cell - 4 3 set-cell - 4 2 set-cell - 4 1 set-cell -[else] +: compile-pattern ( -- ) + begin refill while + parse-word tuck ", + 0= if exit then + repeat +; +: place-pattern ( x y adr -- ) + -rot >cell swap ( board-adr pattern-adr ) + begin dup c@ while ( board-adr pattern-adr ) + 2dup count bounds ?do ( board-adr pattern-adr board-adr ) + i c@ [char] . <> negate ( board-adr pattern-adr board-adr value ) + over c! 1+ ( board-adr pattern-adr board-adr' ) + loop ( board-adr pattern-adr board-adr ) + drop ( board-adr pattern-adr ) + swap lf_width + swap +str ( board-adr' pattern-adr' ) + repeat ( board-adr pattern-adr ) + 2drop +; +: life-pattern: + create compile-pattern + does> ( x y adr ) place-pattern +;
- \ R-pentominos - \ This placement evolves nicely - \ 20 20 set-cell 20 21 set-cell 21 19 set-cell 21 20 set-cell 22 20 set-cell +life-pattern: r-pentomino +.** +**. +.*.
- \ This placement is boring - \ 40 20 set-cell 40 21 set-cell 41 19 set-cell 41 20 set-cell 42 20 set-cell +life-pattern: twin-bees +.OO........................ +.OO........................ +........................... +...............O........... +OO.............OO........OO +OO..............OO.......OO +...........OO..OO.......... +........................... +........................... +........................... +...........OO..OO.......... +OO..............OO......... +OO.............OO.......... +...............O........... +........................... +.OO........................ +.OO........................
- \ This one is excellent! - \ 20 40 set-cell 20 41 set-cell 21 39 set-cell 21 40 set-cell 22 40 set-cell - - \ This one almost dies out, then explodes into a complex arrangement with - \ stuff happening everywhere. - \ 20 60 set-cell 20 61 set-cell 21 59 set-cell 21 60 set-cell 22 60 set-cell +life-pattern: turtle +.OOO.......O +.OO..O.OO.OO +...OOO....O +.O..O.O...O +O....O....O +O....O....O +.O..O.O...O +...OOO....O +.OO..O.OO.OO +.OOO.......O
- \ This one takes a long time to kill off the glider gun, then lasts for a long time - \ 20 80 set-cell 20 81 set-cell 21 79 set-cell 21 80 set-cell 22 80 set-cell +life-pattern: gosper-gun +........................O +......................O.O +............OO......OO............OO +...........O...O....OO............OO +OO........O.....O...OO +OO........O...O.OO....O.O +..........O.....O.......O +...........O...O +............OO
- \ This one takes out the block at the right side of the glider gun, which - \ disperses in an interesting pattern, then the whole arena dies quickly - \ 20 78 set-cell 20 79 set-cell 21 77 set-cell 21 78 set-cell 22 78 set-cell
- \ This one is absolutely brilliant! It takes out the glider gun, which - \ disperse in a boring way, but then the rest of the pattern just keeps - \ changing and changing, after looking like it is about to die several times. - \ It eventually dies about about 5000 generations. - 20 79 set-cell 20 80 set-cell 21 78 set-cell 21 79 set-cell 22 79 set-cell +: erase-board ( -- ) lf_board /board erase ;
- \ Glider gun - 55 21 set-cell - 55 22 set-cell - 56 21 set-cell - 56 22 set-cell - 53 34 set-cell - 53 33 set-cell - 54 32 set-cell - 55 31 set-cell - 56 31 set-cell - 57 31 set-cell - 58 32 set-cell - 59 33 set-cell - 59 34 set-cell - 56 35 set-cell - 54 36 set-cell - 55 37 set-cell - 56 37 set-cell - 56 38 set-cell - 57 37 set-cell - 58 36 set-cell - - 55 41 set-cell - 54 41 set-cell - 53 41 set-cell - 55 42 set-cell - 54 42 set-cell - 53 42 set-cell - - 52 43 set-cell - 52 45 set-cell - 51 45 set-cell - 56 43 set-cell - 56 45 set-cell - 57 45 set-cell - - 53 55 set-cell - 53 56 set-cell - 54 55 set-cell - 54 56 set-cell - -[then] +\ initialize data +: set-cell ( i j -- ) >cell 1 swap c! ; +: init-board ( -- ) ; hex
-: show-board ( -- ) +: generations ( n -- ) cursor-off " erase-screen" $call-screen lf_board_print + ( n ) 0 do + lf_board_evolve + key? if key drop leave then + loop + cursor-on ; +: life-demo ( -- ) + page + erase-board + d# 20 d# 78 r-pentomino + d# 51 d# 21 gosper-gun + d# 5500 generations +;
-\ Version that displays the result in-place -: generations ( n -- ) - show-board - ( n ) 0 do lf_board_evolve loop -; -: life ( #generations -- ) +life-pattern: toad-flipper +.O..............O. +.O..............O. +O.O............O.O +.O..............O. +.O......O.......O. +.O......OO......O. +.O......OO......O. +O.O......O.....O.O +.O..............O. +.O..............O. + + +: flip-toad page - init-board - generations + erase-board + d# 40 d# 40 toad-flipper + d# 500 generations ;
\ 500 generations