home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / tile-forth / sets.f83 < prev    next >
Encoding:
Text File  |  1996-10-12  |  3.2 KB  |  184 lines
  1. \
  2. \  SETS IN VECTOR REPRESENTATION
  3. \
  4. \  Copyright (C) 1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 1 May 1990
  15. \
  16. \  Last updated on: 7 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, blocks
  20. \
  21. \  Description:
  22. \       Management of sets represented as a vector of cells. The set
  23. \       is terminated by the value zero (nil). Thus zero cannot be
  24. \       a member of a set. Used mainly for sets of entries. The tile
  25. \       forth vocabulary search path, "context", is defined as a set
  26. \       of vocabulary entry pointers.
  27. \
  28. \  Copying:
  29. \       This program is free software; you can redistribute it and\or modify
  30. \       it under the terms of the GNU General Public License as published by
  31. \       the Free Software Foundation; either version 1, or (at your option)
  32. \       any later version.
  33. \
  34. \       This program is distributed in the hope that it will be useful,
  35. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  36. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  37. \       GNU General Public License for more details.
  38. \
  39. \       You should have received a copy of the GNU General Public License
  40. \       along with this program; see the file COPYING.  If not, write to
  41. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  42.  
  43. .( Loading Sets definitions...) cr
  44.  
  45. #include blocks.f83
  46.  
  47. vocabulary sets ( -- )
  48.  
  49. blocks sets definitions
  50.  
  51. : set ( size -- )
  52.   create nil here ! cells allot
  53. ;
  54.  
  55. : { ( -- )
  56.   align here ]
  57. ; execution
  58.  
  59. : } ( -- set)
  60.   nil , [compile] [
  61. ; immediate
  62.  
  63. : empty-set ( set -- )
  64.   nil swap !
  65. ;
  66.  
  67. : search-set ( element set -- [addr1] or [element addr2 false])
  68.   swap >r
  69.   begin
  70.     dup @ ?dup
  71.   while
  72.     r@ =
  73.     if r> drop exit then
  74.     cell+
  75.   repeat
  76.   r> swap false
  77. ; private
  78.  
  79. : add-set ( element set -- )
  80.   search-set boolean not if nil over cell+ ! ! then
  81. ;
  82.  
  83. : remove-set ( element set -- )
  84.   search-set ?dup
  85.   if
  86.     begin
  87.       dup cell+ tuck
  88.       @ dup 0= >r swap ! r>
  89.     until
  90.     drop
  91.   else
  92.     2drop
  93.   then
  94. ;
  95.  
  96. : size-set ( set -- num)
  97.   0 swap
  98.   begin
  99.     dup @
  100.   while
  101.     swap 1+ swap cell+
  102.   repeat
  103.   drop
  104. ;
  105.  
  106. : map-set ( set block[element -- ] -- )
  107.   >r
  108.   begin
  109.     dup @ ?dup
  110.   while
  111.     r@ rot >r
  112.     call
  113.     r> cell+
  114.   repeat
  115.   r> 2drop
  116. ;
  117.  
  118. : ?map-set ( set block[element -- bool] -- )
  119.   >r
  120.   begin
  121.     dup @ ?dup
  122.   while
  123.     r@ rot >r
  124.     call
  125.     if 2r> 2drop exit then
  126.     r> cell+
  127.   repeat
  128.   r> 2drop
  129. ;
  130.  
  131. : union-set ( set1 set2 -- )
  132.   >r
  133.   begin
  134.     dup @ ?dup
  135.   while
  136.     r@ add-set cell+
  137.   repeat
  138.   r> 2drop
  139. ;
  140.  
  141. : intersection-set ( set1 set2 -- )
  142.   swap >r
  143.   begin
  144.     dup @ ?dup
  145.   while
  146.     r@ search-set
  147.     if cell+
  148.     else 
  149.       2drop dup
  150.       begin
  151.     dup cell+ tuck
  152.     @ dup 0= >r swap ! r>
  153.       until
  154.       drop
  155.     then
  156.   repeat
  157.   r> 2drop
  158. ;
  159.  
  160. : apply-set ( set -- )
  161.   begin
  162.     dup @ ?dup
  163.   while
  164.     execute cell+
  165.   repeat
  166.   drop
  167. ;
  168.  
  169. : ?member-set ( element set -- bool)
  170.   search-set if true else 2drop false then
  171. ;
  172.  
  173. : ?empty-set ( set -- bool)
  174.   @ 0= 
  175. ;
  176.  
  177. : .set ( set -- )
  178.   ." { "
  179.   block[ ( entry -- ) .name space ]; map-set
  180.   ." } "
  181. ;
  182.  
  183. forth only
  184.