Paste: icfp 2009 vm

! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators grouping io.binary
io.encodings.binary io.files kernel literals math math.bitwise
math.functions sequences fry ;
IN: icfp2009

TUPLE: vm
status
instruction-counter
instructions
data
inputs
outputs ;

CONSTANT: 2^14 $[ 14 2^ ]

: <vm> ( data instruction -- vm )
    vm new
        swap 2^14 0 pad-tail >>instructions
        swap 2^14 0.0 pad-tail >>data
        0 >>instruction-counter
        2^14 0 <array> >>inputs
        2^14 0 <array> >>outputs ;

: D-opp ( n -- n' ) -28 shift ; inline
: D-r1 ( n -- n' ) -14 shift 14 bits ; inline
: D-r2 ( n -- n' ) 14 bits ; inline
: D-regs ( n -- r1 r2 ) [ D-r1 ] [ D-r2 ] bi ; inline
: D-mems ( n vm -- r1 r2 )
    [ D-regs ] dip data>> '[ _ nth ] bi@ ;

: S-opp ( n -- x ) -24 shift ; inline
: S-imm ( n -- x ) -20 shift 3 bits ; inline
: S-r1 ( n -- x ) 14 bits ; inline
: S-mem ( n vm -- x )
    [ S-r1 ] [ data>> nth ] bi* ;

: set-rd ( obj vm -- )
    [ instruction-counter>> ] [ data>> ] bi set-nth ;

: /op ( r1 r2 -- rd )
    dup zero? [ 2drop 0.0 ] [ /f ] if ;

: op-5 ( n vm -- )
    [ D-regs swap ] dip
    [ data>> nth ] [ outputs>> set-nth ] bi-curry
    [ call ] [ call ] bi* ;

: op-6 ( n vm -- )
    dup status>> [
        [ [ D-r1 ] [ data>> nth ] bi* ]
        [ instruction-counter>> ]
        [ data>> ] tri set-nth
    ] [
        [ [ D-r2 ] [ data>> nth ] bi* ]
        [ instruction-counter>> ]
        [ data>> ] tri set-nth
    ] if ;

: run-D-opp ( n vm -- )
    over D-opp {
        { 1 [ [ D-mems + ] [ instruction-counter>> ] [ data>> ] tri set-nth ] }
        { 2 [ [ D-mems - ] [ instruction-counter>> ] [ data>> ] tri set-nth ] }
        { 3 [ [ D-mems * ] [ instruction-counter>> ] [ data>> ] tri set-nth ] }
        { 4 [ [ D-mems /op ] [ instruction-counter>> ] [ data>> ] tri set-nth ] }
        { 5 [ op-5 ] }
        { 6 [ op-6 ] }
        [ "unknown D opp" 2array throw ]
    } case ;

: S-op1 ( n vm -- )
    [
        [ S-mem ] [ drop S-imm ] 2bi {
            { 0 [ 0.0 < ] }
            { 1 [ 0.0 <= ] }
            { 2 [ zero? ] }
            { 3 [ 0.0 >= ] }
            { 4 [ 0.0 > ] }
            [ "bad opcode for S-op1" throw ]
        } case
    ] keep (>>status) ;

: S-op2 ( n vm -- )
    [ S-mem sqrt abs ] keep set-rd ;

: S-op3 ( n vm -- )
    [ S-mem ] keep set-rd ;

: S-op4 ( n vm -- )
    [ [ S-r1 ] [ inputs>> ] bi* nth ] keep set-rd ;

: run-S-opp ( n vm -- )
    over S-opp {
        { 0 [ 2drop ] }
        { 1 [ S-op1 ] }
        { 2 [ S-op2 ] }
        { 3 [ S-op3 ] }
        { 4 [ S-op4 ] }
    } case ;

: fetch-instruction ( vm -- n )
    [ instruction-counter>> ] [ instructions>> ] bi nth ;

: run-opp ( vm -- )
    [ fetch-instruction ] keep
    over D-opp 0 >
    [ run-D-opp ] [ run-S-opp ] if ;

: run-vm ( vm -- )
    '[
        _
        {
            [ instruction-counter>> 0 = [ break ] when ]
            [ run-opp ]
            [ [ 1 + ] change-instruction-counter drop ]
            [ [ [ 2^14 >= ] keep 0 ? ] change-instruction-counter drop ]
        } cleave
        t
    ] loop ;

: pad-scenario-data ( seq -- seq' )
    dup length 24 divisor? [
        dup length dup 24 mod 24 swap - + 0 pad-tail
    ] unless ;

: data-file>vm ( path -- vm )
    binary file-contents
    pad-scenario-data
    12 group 2 group
    [ 1 over [ 4 cut swap append ] change-nth ] map concat [
        8 cut [ le> bits>double ] [ le> ] bi*
    ] { } map>assoc [ keys ] [ values ] bi <vm> ;

: scenario1 ( -- seq ) "vocab:icfp2009/bin1.obf" data-file>vm ;
: scenario2 ( -- seq ) "vocab:icfp2009/bin2.obf" data-file>vm ;
: scenario3 ( -- seq ) "vocab:icfp2009/bin3.obf" data-file>vm ;
: scenario4 ( -- seq ) "vocab:icfp2009/bin4.obf" data-file>vm ;