extra/icfp/2006/2006.factor

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