uses StartUp uses Ext.comment uses Ext.tools /* SETs in FORTH 00:41 01/01/80 by Michael A. Burk Intellisystems ported to GNU Forth by Alex Malyshev (alexript@mail.ru) 16/05/2000 This is an implementation of the sets in FORTH. This was primarily an exercise inspired only by curiosity. If anyone can find a good use for this code, I would be interested in hearing it. */ /* Sets in FORTH This utility allows the construction of data structures containing a set of strings of variable length. The following set functions are implemented: set union set intersection set difference set membership and exclusion set equality Other words are included for various purposes. SETOF --- addr n ( execution ) used in the form: n SETOF e1 e2 ... en where n is the number of elements, and each 'e' is a string in the input stream. This is the basic set constructor, upon which all other operations are based. When is executed, it returns the address of the first element and the number of elements in the set. Example: 4 SETOF SEASONS fall winter spring summer INTERSECT --- addr n ( execution ) used in the form: addr1 n1 addr2 n2 INTERSECT Constructs a new set that represents the intersection of two previously defined sets. UNION --- addr n used in the form: addr1 n1 addr2 n2 UNION Constructs a new set that represents the union of two previously defined sets. DIFFER --- addr n ( execution ) used in the form: addr1 n1 addr2 n2 DIFFER Constructs a new set that represents the difference of two previously defined sets. IN addr addr1 n1 --- f Leaves true if the counted string at addr IS in the set at addr1 , and false otherwise. -IN addr addr1 n1 --- f Leaves false if the counted string at addr is NOT in the set at addr1 , and true otherwise. SET= addr1 n1 addr2 n2 --- f Leaves true if the two sets are equivalent, and false otherwise. Note that this function is NOT order- dependent. TH addr n nth --- nth-addr Leaves the address of the nth element of the set. If nth is not in the range of set, returns 0. WHERE addr addr1 n1 --- cfa n ( found ) --- 0 ( not found ) First determines if the string (or element) is in the set, then attempts to find the element in the dictionary. If successful in both operations, leaves the cfa and a flag ( 1 if the word is marked as IMMEDIATE, and -1 otherwise). If either operation fails, leaves the addr of the element and a false flag. !ELEMENT addr --- Copies the counted string at addr into the dictionary at HERE and allots the proper space. This is only used by the set constructors for building a set. .SET addr n --- Prints all elements of the set in a free format. Used primarily for debugging. EMPTY --- addr 0 A pre-defined set containing no elements. */ ( set functions support 09:32 12/03/85 ) FORTH DEFINITIONS DECIMAL : SETS ; ( addr n -- ) : .SET CR 0 DO ( -- addr ) COUNT ( -- addr+1 u ) 2DUP ( -- addr+1 u addr+1 u ) /* OUT @ ( -- addr+1 u addr+1 u curs_pos ) OVER + cols 2- >= IF CR THEN */ ( -- addr+1 u addr+1 u ) TYPE ( -- addr+1 u ) 2 SPACES + ( -- addr+1+u ) LOOP DROP CR ; ( addr -- ) : !ELEMENT COUNT DUP C, ( store count, ) SWAP OVER ( keep count to allot ) HERE SWAP ( set order for move ) CMOVE ALLOT ; ( set functions support 09:32 12/03/85 ) : INC-LENGTH latestbody ( #elements byte ) DUP C@ 1+ SWAP C! ; ( 1 C+! ) ( set definition: SETOF 09:32 12/03/85 ) : SETOF CREATE DUP C, ( store #elements ) 0 ?DO BL WORD ( get next element ) !ELEMENT LOOP DOES> COUNT ; ( addr & #elements ) ( used in following form: ) ( compilation: #elements -- set-name e1 e2 ... en ) ( execution: setname --> addr #elements ) ( set traversal: TH 09:32 12/03/85 ) ( leaves address of nth element of the set, or 0 if invalid ) ( s-addr #e n -- addr ) : TH 2DUP <= OVER 0< OR IF 3DROP 0 EXIT THEN SWAP DROP 0 ?DO COUNT + LOOP ; ( set membership: IN , -IN 09:32 12/03/85 ) ( in does an element by element string comparison, first assuming false until a match is actually found. ) ( e-addr u set-addr #e -- f ) : IN ( -- e-addr u set-addr #e ) FALSE 4 roll 4 roll 4 roll 4 roll 0 DO ( -- 0 e-addr u set-addr ) 3DUP ( -- 0 e-addr u set-addr e-addr u set-addr ) COUNT ( -- 0 e-addr u set-addr e-addr u se-addr se-u ) CS= ( -- 0 e-addr u set-addr f ) IF ( -- 0 e-addr u set-addr ) 3 roll drop TRUE 3 roll 3 roll 3 roll ( -- -1 e-addr u set-addr ) LEAVE THEN ( -- f e-addr u set-addr ) COUNT + LOOP 3DROP ; ( e-addr set-addr #e -- f ) : -IN IN NOT ; ( set functions support 09:32 12/03/85 ) : !DIFFER-ELEMENTS ( addr1 n1 addr2 n2 --- ) ROT 0 ?DO ( -- addr1 addr2 n2 ) 3DUP ( -- addr1 addr2 n2 addr1 addr2 n2 ) ROT COUNT 2SWAP ( -- addr1 addr2 n2 addr1 u1 addr2 n2 ) -IN ( -- addr1 addr2 n2 f ) IF 2 PICK ( -- addr1 addr2 n2 addr1 ) !ELEMENT INC-LENGTH THEN ROT ( -- addr2 n2 addr1 ) COUNT + ROT ROT ( -- addr1 addr2 n2 ) LOOP 3DROP ; ( set member a word: WHERE 09:32 12/03/85 ) ( Determines if an element is in the set, and then searches the dictionary for the word. If either operation is not successful, returns the addr of the element and false: 0 ) ( e-addr e-u s-addr n -- cfa f found: 1: IMMEDIATE, else -1 ) ( -- 0 not found or not in set ) : WHERE 3 PICK 3 PICK ( -- e-addr e-u s-addr n e-addr e-u ) 2SWAP ( -- e-addr e-u e-addr e-u s-addr n ) IN IF SFIND ELSE 2drop 0 THEN ; ( set union: UNION 09:32 12/03/85 ) ( compilation: s1-addr #e1 s2-addr #e2 -- name ) ( execution: name -> s-addr #e ) : UNION CREATE DUP C, ( -- s1-addr #e1 s2-addr #e2 ) 2DUP ( -- s1-addr #e1 s2-addr #e2 s2-addr #e2 ) 0 ?DO ( -- s1-addr #e1 s2-addr #e2 s2-addr ) DUP !ELEMENT COUNT + LOOP DROP !DIFFER-ELEMENTS DOES> COUNT ; ( set intersection: INTERSECT 09:32 12/03/85 ) ( compilation: s1-addr #e1 s2-addr #e2 -- name ) ( execution: name -> s-addr #e ) : INTERSECT CREATE 0 C, ( -- s1-addr #e1 s2-addr #e2 ) ROT 0 ?DO ( -- s1-addr s2-addr #e2 ) 3DUP ( -- s1-addr s2-addr #e2 s1-addr s2-addr #e2 ) ROT COUNT 2SWAP IN IF 2 PICK !ELEMENT INC-LENGTH THEN ROT COUNT + ROT ROT LOOP 3DROP DOES> COUNT ; ( set difference: DIFFER 09:32 12/03/85 ) ( compilation: s1-addr #e1 s2-addr #e2 -- name ) ( execution: name -> s-addr #e ) : DIFFER CREATE 0 C, 2OVER 2OVER !DIFFER-ELEMENTS 2SWAP !DIFFER-ELEMENTS DOES> COUNT ; ( set equality: SET= 09:32 12/03/85 ) ( addr1 n1 addr2 n2 -- f ) : SET= 2 PICK ( -- addr1 n1 addr2 n2 n1 ) OVER ( -- addr1 n1 addr2 n2 n1 n2 ) <> IF 4DROP FALSE EXIT THEN DUP ( -- addr1 n1 addr2 n2 n2 ) 0= IF 4DROP TRUE EXIT THEN ROT ( -- addr1 addr2 n2 n1 ) 0 DO 3DUP ( -- addr1 addr2 n2 addr1 addr2 n2 ) rot count 2swap -IN IF FALSE ( -- addr1 addr2 n2 0 ) LEAVE THEN ROT ( -- addr2 n2 addr1) COUNT + ROT ROT LOOP ( -- addr1 addr2 n2 ) IF 2DROP TRUE ELSE 3DROP FALSE THEN ; 0 SETOF EMPTY
Make your own free website on Tripod.com