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