extra/gml/core/core.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: accessors arrays assocs classes combinators continuations
   3 gml.printer gml.runtime gml.types grouping hashtables kernel
   4 math ranges sequences sorting ;
   5 IN: gml.core
   6
   7 ! Tokens
   8 GML: cvx ( array -- proc ) { } <proc> ;
   9 GML: cvlit ( proc -- array ) array>> ;
  10 GML: exec ( obj -- ) exec-proc ;
  11
  12 ! Stack shuffling
  13 : pop-slice ( seq n -- subseq )
  14     [ tail ] [ swap shorten ] 2bi ;
  15 : pop-slice* ( seq n -- subseq )
  16     over length swap - pop-slice ;
  17
  18 GML: pop ( a -- ) drop ;
  19 GML: pops ( n -- )
  20     over operand-stack>> [ length swap - ] keep shorten ;
  21 GML: dup ( a -- a a ) dup ;
  22 GML: exch ( a b -- b a ) swap ;
  23 GML: index ( n -- value )
  24     over operand-stack>> [ length 1 - swap - ] keep nth ;
  25
  26 ERROR: roll-out-of-bounds n j ;
  27
  28 GML: roll ( n j -- )
  29     2dup abs < [ roll-out-of-bounds ] when
  30     [ [ dup operand-stack>> ] dip over length swap - pop-slice ] dip
  31     neg over length rem cut-slice swap append over
  32     operand-stack>> push-all ;
  33
  34 GML: clear ( -- ) dup operand-stack>> delete-all ;
  35 GML: cleartomark ( -- )
  36     dup [ find-marker ] [ operand-stack>> ] bi shorten ;
  37 GML: count ( -- n ) dup operand-stack>> length ;
  38 GML: counttomark ( -- n ) dup [ operand-stack>> length ] [ find-marker ] bi - ;
  39
  40 ! Arrays
  41 GML: ] ( -- array )
  42     dup
  43     [ [ operand-stack>> ] [ find-marker ] bi pop-slice { } like ]
  44     [ operand-stack>> pop* ]
  45     bi ;
  46
  47 GML: array ( n -- array )
  48     [ dup operand-stack>> ] dip pop-slice* { } like ;
  49
  50 GML: length ( array -- len ) length ;
  51 GML: append ( array elt -- array' ) suffix ;
  52 GML: eappend ( elt array -- array' ) swap suffix ;
  53
  54 GML: pop-back ( -- array' )
  55     ! Stupid variable arity word!
  56     dup pop-operand dup integer?
  57     [ [ dup pop-operand ] dip head* ] [ but-last ] if ;
  58
  59 GML: pop-front ( -- array' )
  60     ! Stupid variable arity word!
  61     dup pop-operand dup integer?
  62     [ [ dup pop-operand ] dip tail ] [ rest ] if ;
  63
  64 GML: arrayappend ( array1 array2 -- array3 ) append ;
  65 GML: arrayremove ( array1 n -- array3 ) swap wrap remove-nth ;
  66 GML: aload ( array -- ) over operand-stack>> push-all ;
  67 GML: array-get ( array indices -- result ) [ (gml-get) ] with map ;
  68 GML: flatten ( array -- flatarray )
  69     [ dup array? [ 1array ] unless ] map concat ;
  70 GML: reverse ( array -- reversed ) reverse ;
  71 GML: slice ( array n k -- slice )
  72     [a..b) swap '[ _ wrap nth ] map ;
  73 GML:: subarray ( array n k -- slice )
  74     k n k + array subseq ;
  75 GML: sort-number-permutation ( array -- permutation )
  76     zip-index sort-keys <reversed> values ;
  77
  78 ! Dictionaries
  79 : check-dict ( obj -- obj' ) hashtable check-instance ; inline
  80
  81 GML: begin ( dict -- ) check-dict over dictionary-stack>> push ;
  82 GML: end ( -- ) dup dictionary-stack>> pop* ;
  83 GML: dict ( -- dict ) H{ } clone ;
  84
  85 GML: dictfromarray ( -- dict )
  86     ! Stupid variable-arity word!
  87     dup pop-operand {
  88         { [ dup hashtable? ] [ [ dup pop-operand ] dip ] }
  89         { [ dup array? ] [ H{ } clone ] }
  90     } cond
  91     swap 2 group assoc-union! ;
  92
  93 GML: keys ( dict -- keys ) keys ;
  94 GML: known ( dict key -- ? ) swap key? >true ;
  95 GML: values ( dict -- values ) values ;
  96 GML: where ( key -- ? )
  97     ! Stupid variable-arity word!
  98     over dictionary-stack>> [ key? ] with find swap
  99     [ over push-operand 1 ] [ drop 0 ] if ;
 100
 101 : current-dict ( gml -- assoc ) dictionary-stack>> last ; inline
 102
 103 GML: currentdict ( -- dict ) dup current-dict ;
 104 GML: load ( name -- value ) over lookup-name ;
 105
 106 : check-name ( obj -- obj' ) gml-name check-instance ; inline
 107
 108 GML: def ( name value -- ) swap check-name pick current-dict set-at ;
 109 GML: edef ( value name -- ) check-name pick current-dict set-at ;
 110 GML: undef ( name -- ) check-name over current-dict delete-at ;
 111
 112 ! Dictionaries and arrays
 113 GML: get ( collection key -- elt ) (gml-get) ;
 114 GML: put ( collection key elt -- ) (gml-put) ;
 115 GML: copy ( collection -- collection' ) (gml-copy) ;
 116
 117 ! Control flow
 118 : proc>quot ( proc -- quot: ( registers gml -- registers gml ) )
 119     '[ _ exec-proc ] ; inline
 120 : proc>quot1 ( proc -- quot: ( registers gml value -- registers gml ) )
 121     '[ over push-operand _ exec-proc ] ; inline
 122 : proc>quot2 ( proc -- quot: ( registers gml value1 value2 -- registers gml ) )
 123     '[ [ over push-operand ] bi@ _ exec-proc ] ; inline
 124
 125 GML: if ( flag proc -- ) [ true? ] [ proc>quot ] bi* when ;
 126 GML: ifelse ( flag proc0 proc1 -- ) [ true? ] [ proc>quot ] [ proc>quot ] tri* if ;
 127 GML:: ifpop ( x y flag -- x/y ) flag true? y x ? ;
 128 GML: exit ( -- ) return ;
 129 GML: loop ( proc -- )
 130     '[ _ proc>quot '[ @ t ] loop ] with-return ;
 131 GML: repeat ( n proc -- )
 132     '[ _ _ proc>quot times ] with-return ;
 133 GML: for ( a s b proc -- )
 134     '[ _ _ _ _ [ swap <range> ] dip proc>quot1 each ] with-return ;
 135 GML: forx ( a s b proc -- )
 136     '[ _ _ _ _ [ 1 - swap <range> ] dip proc>quot1 each ] with-return ;
 137 GML: forall ( array proc -- )
 138     '[ _ _ proc>quot1 each ] with-return ;
 139 GML: twoforall ( array1 array2 proc -- )
 140     '[ _ _ _ proc>quot2 2each ] with-return ;
 141 GML:: map ( array proc -- )
 142     :> gml
 143     marker gml push-operand
 144     gml array proc proc>quot1 each
 145     gml-] ;
 146 GML:: twomap ( array1 array2 proc -- )
 147     :> gml
 148     marker gml push-operand
 149     gml array1 array2 proc proc>quot2 2each
 150     gml-] ;
 151
 152 ! Extensions to real GML
 153 GML: print ( obj -- ) print-gml ;
 154 GML: test ( obj1 obj2 -- ) swap assert= ;