extra/icfp/2006/2006.factor

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