extra/icfp/2006/2006.factor

   1 ! Copyright (C) 2007 Gavin Harrison
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays combinators endian grouping io io.encodings.binary
   4 io.files kernel math math.functions namespaces sequences vectors ;
   5 IN: icfp.2006
   6
   7 SYMBOL: regs
   8 SYMBOL: arrays
   9 SYMBOL: finger
  10 SYMBOL: open-arrays
  11
  12 : reg-val ( m -- n ) regs get nth ;
  13
  14 : set-reg ( val n -- ) regs get set-nth ;
  15
  16 : arr-val ( index loc -- z )
  17     arrays get nth nth ;
  18
  19 : set-arr ( val index loc -- )
  20     arrays get nth set-nth ;
  21
  22 : get-op ( num -- op )
  23     -28 shift 0b1111 bitand ;
  24
  25 : get-value ( platter -- register )
  26     0x1ffffff bitand ;
  27
  28 : >32bit ( m -- n ) 0xffffffff bitand ; inline
  29
  30 : get-a ( platter -- register )
  31     -6 shift 0b111 bitand ; inline
  32
  33 : get-b ( platter -- register )
  34     -3 shift 0b111 bitand ; inline
  35
  36 : get-c ( platter -- register )
  37     0b111 bitand ; inline
  38
  39 : get-cb ( platter -- b c ) [ get-c ] keep get-b ;
  40 : get-cba ( platter -- c b a ) [ get-cb ] keep get-a ;
  41 : get-special ( platter -- register )
  42     -25 shift 0b111 bitand ; inline
  43
  44 : op0 ( opcode -- ? )
  45     get-cba rot reg-val zero? [
  46         2drop
  47     ] [
  48         [ reg-val ] dip set-reg
  49     ] if f ;
  50
  51 : binary-op ( quot -- ? )
  52     [ get-cba ] dip
  53     swap [ [ [ reg-val ] bi@ swap ] dip call ] dip
  54     set-reg f ; inline
  55
  56 : op1 ( opcode -- ? )
  57     [ swap arr-val ] binary-op ;
  58
  59 : op2 ( opcode -- ? )
  60     get-cba [ [ reg-val ] bi@ ] dip reg-val set-arr f ;
  61
  62 : op3 ( opcode -- ? )
  63     [ + >32bit ] binary-op ;
  64
  65 : op4 ( opcode -- ? )
  66     [ * >32bit ] binary-op ;
  67
  68 : op5 ( opcode -- ? )
  69     [ /i ] binary-op ;
  70
  71 : op6 ( opcode -- ? )
  72     [ bitand 0xffffffff swap - ] binary-op ;
  73
  74 : new-array ( size location -- )
  75     [ 0 <array> ] dip arrays get set-nth ;
  76
  77 : ?grow-storage ( -- )
  78     open-arrays get dup empty? [
  79         [ arrays get length ] dip push
  80     ] [
  81         drop
  82     ] if ;
  83
  84 : op8 ( opcode -- ? )
  85     ?grow-storage
  86     get-cb [ reg-val open-arrays get pop [ new-array ] keep ] dip
  87     set-reg f ;
  88
  89 : op9 ( opcode -- ? )
  90     get-c reg-val dup open-arrays get push
  91     f swap arrays get set-nth f ;
  92
  93 : op10 ( opcode -- ? )
  94     get-c reg-val write1 flush f ;
  95
  96 : op11 ( opcode -- ? )
  97     drop f ;
  98
  99 : op12 ( opcode -- ? )
 100     get-cb reg-val dup zero? [
 101         drop
 102     ] [
 103         arrays get [ nth clone 0 ] keep set-nth
 104     ] if reg-val finger set f ;
 105
 106 : op13 ( opcode -- ? )
 107     [ get-value ] keep get-special set-reg f ;
 108
 109 : advance ( -- val opcode )
 110     finger get arrays get first nth
 111     finger inc dup get-op ;
 112
 113 : run-op ( -- bool )
 114     advance
 115     {
 116         { 0 [ op0 ] }
 117         { 1 [ op1 ] }
 118         { 2 [ op2 ] }
 119         { 3 [ op3 ] }
 120         { 4 [ op4 ] }
 121         { 5 [ op5 ] }
 122         { 6 [ op6 ] }
 123         { 7 [ drop t ] }
 124         { 8 [ op8 ] }
 125         { 9 [ op9 ] }
 126         { 10 [ op10 ] }
 127         { 11 [ op11 ] }
 128         { 12 [ op12 ] }
 129         { 13 [ op13 ] }
 130     } case ;
 131
 132 : exec-loop ( bool -- )
 133     [ run-op exec-loop ] unless ;
 134
 135 : load-platters ( path -- )
 136     binary file-contents 4 group [ be> ] map
 137     0 arrays get set-nth ;
 138
 139 : init ( path -- )
 140     8 0 <array> regs set
 141     2 16 ^ <vector> arrays set
 142     0 finger set
 143     V{ } clone open-arrays set
 144     load-platters ;
 145
 146 : run-prog ( path -- )
 147     init f exec-loop ;
 148
 149 : run-sand ( -- )
 150     "resource:extra/icfp/2006/sandmark.umz" run-prog ;