factor/extra/icfp/2006/2006.factor

152 lines
3.2 KiB
Factor
Raw Normal View History

2007-09-20 18:09:08 -04:00
! Copyright (C) 2007 Gavin Harrison
! See http://factorcode.org/license.txt for BSD license.
2008-02-14 02:06:27 -05:00
USING: kernel math sequences kernel.private namespaces arrays io
2008-06-09 06:22:21 -04:00
io.files splitting grouping io.binary math.functions vectors
quotations combinators io.encodings.binary ;
2007-11-04 22:51:34 -05:00
IN: icfp.2006
2007-09-20 18:09:08 -04:00
SYMBOL: regs
SYMBOL: arrays
SYMBOL: finger
SYMBOL: open-arrays
: reg-val ( m -- n ) regs get nth ;
: set-reg ( val n -- ) regs get set-nth ;
: arr-val ( index loc -- z )
arrays get nth nth ;
: set-arr ( val index loc -- )
arrays get nth set-nth ;
: get-op ( num -- op )
2011-11-23 21:49:33 -05:00
-28 shift 0b1111 bitand ;
2007-09-20 18:09:08 -04:00
: get-value ( platter -- register )
2011-11-23 21:49:33 -05:00
0x1ffffff bitand ;
2007-09-20 18:09:08 -04:00
2011-11-23 21:49:33 -05:00
: >32bit ( m -- n ) 0xffffffff bitand ; inline
2007-09-20 18:09:08 -04:00
: get-a ( platter -- register )
2011-11-23 21:49:33 -05:00
-6 shift 0b111 bitand ; inline
2007-09-20 18:09:08 -04:00
: get-b ( platter -- register )
2011-11-23 21:49:33 -05:00
-3 shift 0b111 bitand ; inline
2007-09-20 18:09:08 -04:00
: get-c ( platter -- register )
2011-11-23 21:49:33 -05:00
0b111 bitand ; inline
2007-09-20 18:09:08 -04:00
: get-cb ( platter -- b c ) [ get-c ] keep get-b ;
: get-cba ( platter -- c b a ) [ get-cb ] keep get-a ;
: get-special ( platter -- register )
2011-11-23 21:49:33 -05:00
-25 shift 0b111 bitand ; inline
2007-09-20 18:09:08 -04:00
: op0 ( opcode -- ? )
get-cba rot reg-val zero? [
2drop
] [
2008-12-18 00:36:13 -05:00
[ reg-val ] dip set-reg
2007-09-20 18:09:08 -04:00
] if f ;
: binary-op ( quot -- ? )
2008-12-18 00:36:13 -05:00
[ get-cba ] dip
swap [ [ [ reg-val ] bi@ swap ] dip call ] dip
2007-09-20 18:09:08 -04:00
set-reg f ; inline
2007-09-20 18:09:08 -04:00
: op1 ( opcode -- ? )
[ swap arr-val ] binary-op ;
: op2 ( opcode -- ? )
2008-12-18 00:36:13 -05:00
get-cba [ [ reg-val ] bi@ ] dip reg-val set-arr f ;
2007-09-20 18:09:08 -04:00
: op3 ( opcode -- ? )
[ + >32bit ] binary-op ;
: op4 ( opcode -- ? )
[ * >32bit ] binary-op ;
: op5 ( opcode -- ? )
[ /i ] binary-op ;
: op6 ( opcode -- ? )
2011-11-23 21:49:33 -05:00
[ bitand 0xffffffff swap - ] binary-op ;
2007-09-20 18:09:08 -04:00
: new-array ( size location -- )
2008-12-18 00:36:13 -05:00
[ 0 <array> ] dip arrays get set-nth ;
2007-09-20 18:09:08 -04:00
: ?grow-storage ( -- )
open-arrays get dup empty? [
2008-12-18 00:36:13 -05:00
[ arrays get length ] dip push
2007-09-20 18:09:08 -04:00
] [
drop
] if ;
: op8 ( opcode -- ? )
?grow-storage
2008-12-18 00:36:13 -05:00
get-cb [ reg-val open-arrays get pop [ new-array ] keep ] dip
2007-09-20 18:09:08 -04:00
set-reg f ;
: op9 ( opcode -- ? )
get-c reg-val dup open-arrays get push
f swap arrays get set-nth f ;
: op10 ( opcode -- ? )
get-c reg-val write1 flush f ;
: op11 ( opcode -- ? )
drop f ;
: op12 ( opcode -- ? )
get-cb reg-val dup zero? [
drop
] [
arrays get [ nth clone 0 ] keep set-nth
] if reg-val finger set f ;
: op13 ( opcode -- ? )
[ get-value ] keep get-special set-reg f ;
2007-09-20 18:09:08 -04:00
: advance ( -- val opcode )
finger get arrays get first nth
finger inc dup get-op ;
: run-op ( -- bool )
advance
{
2008-02-14 02:06:27 -05:00
{ 0 [ op0 ] }
{ 1 [ op1 ] }
{ 2 [ op2 ] }
{ 3 [ op3 ] }
{ 4 [ op4 ] }
{ 5 [ op5 ] }
{ 6 [ op6 ] }
{ 7 [ drop t ] }
{ 8 [ op8 ] }
{ 9 [ op9 ] }
{ 10 [ op10 ] }
{ 11 [ op11 ] }
{ 12 [ op12 ] }
{ 13 [ op13 ] }
} case ;
2007-09-20 18:09:08 -04:00
: exec-loop ( bool -- )
[ run-op exec-loop ] unless ;
: load-platters ( path -- )
binary file-contents 4 group [ be> ] map
2007-09-20 18:09:08 -04:00
0 arrays get set-nth ;
: init ( path -- )
8 0 <array> regs set
2 16 ^ <vector> arrays set
0 finger set
V{ } clone open-arrays set
load-platters ;
: run-prog ( path -- )
init f exec-loop ;
: run-sand ( -- )
"resource:extra/icfp/2006/sandmark.umz" run-prog ;