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;