1\ Integer vectors library Thu Feb 21 12:46:01 MST 2008 2\ Copyright (C) 2008, Sergey Plis 3\ 4\ This program is free software; you can redistribute it and/or modify 5\ it under the terms of the GNU General Public License as published by 6\ the Free Software Foundation; either version 2 of the License, or 7\ (at your option) any later version. 8\ 9\ This program is distributed in the hope that it will be useful, 10\ but WITHOUT ANY WARRANTY; without even the implied warranty of 11\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12\ GNU General Public License for more details. 13 14\needs float import float 15 16\ vector variables better have names ending with "(" for readability 17Module vectors 18also float 19 20\ fetches 21| create fetch_operations ' c@ , ' w@ , ' @ , 0 , ' 2@ , ' f@ , 22 23\ stores 24| create store_operations ' c! , ' w! , ' ! , 0 , ' 2! , ' f! , 25| : type-idx ( cell_size -- idx ) 4 >> ; macro 26| : f-op ( cell-size -- cfa ) type-idx cells fetch_operations + @ ; 27| : s-op ( cell-size -- cfa ) type-idx cells store_operations + @ ; 28 29: ^)! ( *vector -- addr ) [ 3 cells ] literal - @ ; 30: ^)@ ( *vector -- addr ) [ 4 cells ] literal - @ ; 31 32\ number of elements 33: )size ( *vector -- size ) [ 1 cells ] literal - @ ; 34 35\ set number of elements - useful for temporal size adjustments in 36\ datastructures such as heaps 37: )size! ( sz *vector -- ) [ 1 cells ] literal - ! ; 38 39\ size of an element in bytes 40: )type ( *vector -- size ) [ 2 cells ] literal - @ ; 41 42: )free ( *vector -- ) [ 4 cells ] literal - free throw ; 43 44\ header | fetch_cfa | store_cfa | el_size | #els | 45\ cell-size in bits 46\ unnamed vector 47: _vector ( n cell-size -- addr ) 48 2dup * [ 4 cells ] literal + allocate throw 49 dup >r over f-op swap ! 50 r@ cell+ over s-op swap ! 51 r@ [ 2 cells ] literal + ! \ cell size store 52 r@ [ 3 cells ] literal + ! \ #els store 53 r> [ 4 cells ] literal + ; 54 55\ named vector 56: vector ( n cell-size -- ) 57 create 58 2dup * [ 4 cells ] literal + allocate throw dup , 59 dup >r over f-op swap ! 60 r@ cell+ over s-op swap ! 61 r@ [ 2 cells ] literal + ! \ cell size store 62 r@ [ 3 cells ] literal + ! \ #els store 63 r> dup 64 \ erasing the content 65 [ 2 cells ] literal + @ over [ 3 cells ] literal + @ * 66 swap [ 4 cells ] literal + swap erase 67 does> @ [ 4 cells ] literal + ; 68 69\ vector of pointers 70: vector* ( # -- *vector ) cell 8 * _vector ; 71 72| : ?idx-in-range ( *vector idx -- 1/0 ) dup rot )size < swap 0>= and ; 73| : check-range ( *vector idx -- *vector idx | fail ) 74 2dup ?idx-in-range not abort" Index is out of range! " ; 75 76\ addr of ith element of the vector 77: *) ( *vector i -- addr ) over )type 3 >> * + ; 78: )@ ( *vector index -- ) 79 [IFDEF] отладка 80 check-range 81 [THEN] 82 over dup ^)@ >r )type 3 >> * + r> execute ; 83: )! ( value *vector index -- ) 84 [IFDEF] отладка 85 check-range 86 [THEN] 87 over dup ^)! >r )type 3 >> * + r> execute ; 88\ : test! cell * + ! ; 89| create print-funcs ' . , ' . , ' . , 0 , ' d. , ' f. , 90: )print ( *v -- cfa ) )type type-idx cells print-funcs + @ execute ; 91: )map ( *v xt -- ) swap dup )size 0 do 2dup i )@ swap execute loop 2drop ; 92: map ( *v -- ) ( word-to-map ) ' swap dup )size 0 do 2dup i )@ swap execute loop 2drop ; 93: )initperm ( v( -- ) 94 dup )size 0 do 95 dup 96 i swap over )! 97 loop drop ; 98: ). ( *vector -- ) dup )size 0 do dup i )@ over )print loop drop ; 99\ does arbitrary vector contain this element ? 100: )in? ( *v value -- 1/0 ) 101 swap dup )size 0 do 102 2dup i )@ = if 2drop True unloop exit then 103 loop 2drop False ; 104: )find ( *v value -- i True/False ) 105 swap dup )size 0 do 106 2dup i )@ = if 2drop i True unloop exit then 107 loop 2drop False ; 108: vector->stack ( *v -- n1 n2 .. n# # ) 109 dup )size 0 do dup i )@ swap loop )size ; 110\ initialized cell vector 111\ preserve order 112: ivector* ( n1 n2 .. n# # -- *vector ) 113 dup vector* swap 1- 0 swap do 114 swap over i )! 115 -1 +loop ; 116\ reversed order 117: irvector* ( n1 n2 .. n# # -- *vector ) 118 dup vector* swap 0 do 119 swap over i )! 120 loop ; 121\ does not take care of duplicate elements 122| : overlap ( v1( v2( -- n1 .. n2 # / 0 ) depth 2- >r 123 dup )size 0 do 124 2dup i )@ )in? if 125 dup i )@ -rot 126 then 127 loop 2drop depth r> - ; 128| : notoverlap ( v1( v2( -- n1 .. n2 # ) 129 depth 2- >r 130 dup )size 0 do 131 2dup i )@ )in? not if 132 dup i )@ -rot 133 then 134 loop 2drop depth r> - ; 135: )union ( *v1( *v2( -- *v3( ) 136 over >r 137 notoverlap 138 r> swap >r vector->stack r> + 139 dup 0= abort" empty union!" 140 ivector* ; 141: )intersection ( *v1( *v2( -- *v3(/0 ) 142 overlap dup 0<> if ivector* then ; 143\ elementwise comparison of two vectors 144: )= ( *v1( *v2( -- 1/0 ) dup )size >r over )size r> 145 <> if 2drop 0 exit then 146 dup )size 0 do 147 2dup i )@ swap i )@ <> if 148 2drop unloop 0 exit 149 then 150 loop 2drop -1 ; 151: subset? ( *v( *s( -- 1/0 ) 152 2dup )intersection dup 0= if -rot 2drop exit then 153 dup >r )= swap drop r> )free ; 154: )clone ( *v -- *cv ) 155 vector->stack ivector* ; 156: )erase ( *v -- ) dup )size over )type 3 >> * erase ; 157: _last ( *v -- *v idx-of-last-element ) dup )size 1- ; 158 159clear 160previous 161Module;