\ ********** for defining the rule tables **************** 00 03 == uls 00 00 == ul0 01 01 == ul1 02 02 == ul2 03 03 == ul3 04 07 == urs 04 04 == ur0 05 05 == ur1 06 06 == ur2 07 07 == ur3 08 11 == lls 08 08 == ll0 09 09 == ll1 10 10 == ll2 11 11 == ll3 12 15 == lrs 12 12 == lr0 13 13 == lr1 14 14 == lr2 15 15 == lr3 create-lut even-table create-lut odd-table create-lut reverse-table : even>odd even-table buffer odd-table buffer length /w* cmove ; : even>reverse even-table buffer reverse-table buffer length /w* cmove ; : propagate update ul0 <-> lr0 ll0 <-> ur0 ul1 <-> lr1 ll1 <-> ur1 ul2 <-> lr2 ll2 <-> ur2 ul3 <-> lr3 ll3 <-> ur3 ; create-lut propagate-table ?rule>table propagate propagate-table \ ******** neighbors for rotsym rules ********* 16 17 == hv 16 16 == horz 17 17 == vert : begin-rotsym compile 4 compile 0 [compile] do compile i compile lut-in compile w! ; immediate : end-rotsym [compile] loop compile propagate ; immediate : center0 hv {{ ul0 ur0 ll0 lr0 }} ; : center1 hv {{ ul1 ur1 ll1 lr1 }} ; : center2 hv {{ ul2 ur2 ll2 lr2 }} ; : center3 hv {{ ul3 ur3 ll3 lr3 }} ; : cw0 hv {{ ur0 lr0 ul0 ll0 }} ; : cw1 hv {{ ur1 lr1 ul1 ll1 }} ; : cw2 hv {{ ur2 lr2 ul2 ll2 }} ; : cw3 hv {{ ur3 lr3 ul3 ll3 }} ; : ccw0 hv {{ ll0 ul0 lr0 ur0 }} ; : ccw1 hv {{ ll1 ul1 lr1 ur1 }} ; : ccw2 hv {{ ll2 ul2 lr2 ur2 }} ; : ccw3 hv {{ ll3 ul3 lr3 ur3 }} ; : opp0 hv {{ lr0 ll0 ur0 ul0 }} ; : opp1 hv {{ lr1 ll1 ur1 ul1 }} ; : opp2 hv {{ lr2 ll2 ur2 ul2 }} ; : opp3 hv {{ lr3 ll3 ur3 ul3 }} ; : >uls -> uls ; : >urs -> urs ; : >lls -> lls ; : >lrs -> lrs ; : >center0 center0 !! ; : >center1 center1 !! ; : >center2 center2 !! ; : >center3 center3 !! ; : centers hv {{ uls urs lls lrs }} ; : >centers hv {{ >uls >urs >lls >lrs }} ; : pair (s a b -- a+2b ) 2* + ; \* Note: Don't use "update" together with rotsym. *\ \ ******************* define the steps ********************* define-step free-step full-space lut-src site site-src lut kick lr0 field -1 x -1 y ur0 field -1 x 0 y ll0 field 0 x -1 y lr1 field -1 x -1 y ur1 field -1 x 0 y ll1 field 0 x -1 y lr2 field -1 x -1 y ur2 field -1 x 0 y ll2 field 0 x -1 y lr3 field -1 x -1 y ur3 field -1 x 0 y ll3 field 0 x -1 y run free switch-luts kick ul0 field 1 x 1 y ll0 field 1 x 0 y ur0 field 0 x 1 y ul1 field 1 x 1 y ll1 field 1 x 0 y ur1 field 0 x 1 y ul2 field 1 x 1 y ll2 field 1 x 0 y ur2 field 0 x 1 y ul3 field 1 x 1 y ll3 field 1 x 0 y ur3 field 0 x 1 y run free switch-luts end-step this is update-step define-step undo-first-kick site-src site kick lr0 field 1 x 1 y ur0 field 1 x 0 y ll0 field 0 x 1 y lr1 field 1 x 1 y ur1 field 1 x 0 y ll1 field 0 x 1 y lr2 field 1 x 1 y ur2 field 1 x 0 y ll2 field 0 x 1 y lr3 field 1 x 1 y ur3 field 1 x 0 y ll3 field 0 x 1 y run end-step define-step redo-first-kick site-src site kick lr0 field -1 x -1 y ur0 field -1 x 0 y ll0 field 0 x -1 y lr1 field -1 x -1 y ur1 field -1 x 0 y ll1 field 0 x -1 y lr2 field -1 x -1 y ur2 field -1 x 0 y ll2 field 0 x -1 y lr3 field -1 x -1 y ur3 field -1 x 0 y ll3 field 0 x -1 y run end-step \ We prepare to run backwards by performing a transformation on the \ state of the system that reverses the "momentum" of all particles. We \ first apply this transformation as if it was the even-step rule, then \ we undo the propagate part of the rule and move the data back where it \ started. Subsequent evolution uses the normal "free-step" rule. define-step reverse-step full-space lut-src site site-src lut lut-data reverse-table switch-luts kick lr0 field -1 x -1 y ur0 field -1 x 0 y ll0 field 0 x -1 y lr1 field -1 x -1 y ur1 field -1 x 0 y ll1 field 0 x -1 y lr2 field -1 x -1 y ur2 field -1 x 0 y ll2 field 0 x -1 y lr3 field -1 x -1 y ur3 field -1 x 0 y ll3 field 0 x -1 y run free \ reverse state lut-data propagate-table switch-luts kick run free \ undo propagation kick lr0 field 1 x 1 y ur0 field 1 x 0 y ll0 field 0 x 1 y lr1 field 1 x 1 y ur1 field 1 x 0 y ll1 field 0 x 1 y lr2 field 1 x 1 y ur2 field 1 x 0 y ll2 field 0 x 1 y lr3 field 1 x 1 y ur3 field 1 x 0 y ll3 field 0 x 1 y site-src site run free \ move the data back end-step \ ******************* run the experiment ******************** define-step send-tables full-space lut-data even-table switch-luts lut-data odd-table end-step : init-2x2 send-tables undo-first-kick ; this is when-starting : ending-kick redo-first-kick ; this is when-stopping : ?redo-first-kick stepping @ if redo-first-kick then ; this is before-display : ?undo-first-kick stepping @ if undo-first-kick then ; this is after-display : density-map 0 >color ul0 ur0 ll0 lr0 + + + bright 4 / * dup >green >red ul1 ur1 ll1 lr1 + + + bright 4 / * >blue ; colormap density-map \ ****************** redefine some colormap stuff ******************** variable inten \ >red, >blue, >green, etc. should saturate at max value \ : layers@ ; \ : +>layers lut-in @ update layers@ swap + >layers lut-in ! ; \ : +-> state @ if compile (+layers) else ' +>layers then ; immediate \ : +!! drop last== @ body> +>layers ; : >inten inten ! ; : >inten+ inten @ + bright min 0 max inten ! ; : >red+ lut-in @ update red-intensity swap + >red lut-in ! ; : >blue+ lut-in @ update blue-intensity swap + >blue lut-in ! ; : >green+ lut-in @ update green-intensity swap + >green lut-in ! ; : palette! (s cfa-rule cfa-buf -- ) dup guarantee-alloc dup >buf-reglen @ /w* ( cfa-rule cfa-buf buf-len ) swap >buf-addr.u @ ( cfa-rule buf-len buf-addr.u ) dup -rot swap bounds do ( cfa-rule buf-addr ) i over - 3 >> ( cfa-rule buf-addr entry# ) dup lut-in ! lut-out ! ( cfa-rule buf-addr ) 4 1 do ( c-r b-a ith-palette-entry ) 0 lut-out 3 i - ca+ c! ( c-r b-a ) \ 0 into lut-out loop 0 >inten over execute update red-intensity inten @ + >red blue-intensity inten @ + >blue green-intensity inten @ + >green 4 0 do lut-out 3 i - ca+ c@ ( c-r b-a ith-palette-entry ) j i wa+ w! \ copy out to palette loop 8 +loop 2drop ; : send-unspread ['] palette palette! ?palette>display ; : colormap state @ if [compile] ['] compile send-unspread else ' send-unspread then ; immediate