extra/gml/core/core.factor

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