(* * LANGUAGE : ANS Forth with extensions * PROJECT : Forth Environments * DESCRIPTION : Generate all permutations in lexical order. * CATEGORY : Difficult Standard Programming Problems * AUTHOR : Wil Baden 339 Princeton Drive Costa Mesa CA 92626 714-546-9894 * LAST CHANGE : May 13, 1994, Marcel Hendrix *) NEEDS -miscutil \ NEEDS -pronun CD ../dawg NEEDS -dawg CD ../games REVISION -anagrams "ÄÄÄ Permutations Version 1.02 ÄÄÄ" PRIVATES DOC (* Generating all permutations of a list of objects is a classical simple but definitely non-trivial problem in computing science. There are many solutions and if you have never done it before you might try before seeing how it has been done here. This is a Forth implementation of a method attributed to Edsger Dijkstra. FORTH> cr timer-reset s" wilbaden" anabenchx . .elapsed 5976 1.323 seconds elapsed. ok *) ENDDOC -- Exchange bytes at addr1 and addr2. :INLINE CEXCH ( addr1 addr2 -- ) OVER C@ OVER C@ SWAP ROT C! SWAP C! ; -- Reverse the bytes in a string. E.g., " FORTH" becomes " HTROF". : REVERSE ( c-addr u -- ) 2DUP CHARS + -ROT 2/ BOUNDS ?DO CHAR- DUP I CEXCH LOOP DROP ;P -- Find the last stepup in a string, that is, the last i such that the byte -- contents at addr+i-1 is less than the byte contents at addr+i . E.g., -- in " JANUARY" there is a stepup from A to N, from N to U, from A to R, -- and from R to Y. -- " JANUARY" STEPUP returns 6. A string in reverse order, such as -- " ROMA", returns 0. : STEPUP ( a n -- i : Find last i such that a[i-1] < a[i].) 1- 1 SWAP DO DUP I + DUP 1- C@ SWAP C@ < IF DROP I UNLOOP EXIT ENDIF -1 +LOOP 0= ;P -- Find last byte in a string such that the first byte is less than it and -- then exchange them. E.g., in " JUNE" J is before U and N. So " JUNE" -- 2DUP JUGGLE becomes " NUJE". : JUGGLE ( a n -- ) 1- 1 SWAP DO DUP C@ OVER I + C@ < IF DUP I + CEXCH UNLOOP EXIT ENDIF -1 +LOOP DROP ;P -- Convert a string to the next permutation in lexical order. E.g. " FORTH" -- 2DUP PERMUTE becomes " FOTHR". -- To show how it works let's start with " FOTRH". The last stepup is O -- to T so STEPUP returns 2. We then shorten the string and JUGGLE " OTRH" -- which becomes " RTOH". We take the rest of the string " TOH" and -- REVERSE it so that it becomes " HOT". Put them all together they spell -- " FRHOT". -- When STEPUP returns 0 we bypass JUGGLE and just REVERSE the string. Thus -- " TROHF" becomes " FHORT". The values of the bytes do not have to be -- distinct. : PERMUTE ( addr u -- ) 2DUP STEPUP ?DUP IF 1- /STRING 2DUP JUGGLE 1 /STRING ENDIF REVERSE ; CREATE cons PRIVATE #256 CHARS ALLOT : PREP cons #256 CHARS 1 FILL cons BL + C0! cons 'a' + C0! cons 'A' + C0! cons 'e' + C0! cons 'E' + C0! cons 'i' + C0! cons 'I' + C0! cons 'o' + C0! cons 'O' + C0! cons 'u' + C0! cons 'U' + C0! cons 'y' + C0! cons 'Y' + C0! ;P PREP FORGET PREP -- If a string has consecutive runs of more than 2 non-consonants, -- it is likely to be unpronouncable. DEFER PRONOUNCABLE? PRIVATE : (PRONOUNCABLE?) ( c-addr u -- bool ) 0 LOCAL run BOUNDS ?DO I C@ CHARS cons + C@ IF 1 +TO run ELSE CLEAR run ENDIF run 2 > ?LEAVE LOOP run 2 <= ;P -- Display all permutations of a string. : (ANAGRAMS) ( c-addr u -- ) C/L #16 - OVER 2+ / 0 #256 LOCALS| skip ix #s | 2DUP PAD PACK DROP \ keep original CR BEGIN 2DUP PRONOUNCABLE? IF 2DUP TYPE 2 SPACES ( -- s1 ) 1 +TO ix ix #s >= IF CR CLEAR ix ENDIF ENDIF 2DUP PERMUTE ( -- s2 ) 2DUP PAD COUNT COMPARE 0= 1 -TO skip skip 0<= IF EKEY? OR #256 TO skip ENDIF UNTIL 2DROP ; -- Count all permutations of a string. : (ANABENCH) ( c-addr u -- count ) 0 0 0 #256 LOCALS| skip scnt str cnt | 2DUP PAD PACK DROP \ keep original PAD COUNT TO scnt TO str BEGIN 2DUP PRONOUNCABLE? 1 AND +TO cnt 2DUP PERMUTE ( -- s2 ) 2DUP str scnt COMPARE 0= 1 -TO skip skip 0<= IF EKEY? OR #256 TO skip ENDIF UNTIL 2DROP cnt ; : ANAGRAMS ( c-addr u -- ) ['] U> IS PRONOUNCABLE? (ANAGRAMS) ; : ANAGRAMS+ ( c-addr u -- ) ['] (PRONOUNCABLE?) IS PRONOUNCABLE? (ANAGRAMS) ; : ANAGRAMSx ( c-addr u -- ) ['] $QUALIFY? IS PRONOUNCABLE? (ANAGRAMS) ; : ANABENCH ( c-addr u -- u ) ['] U> IS PRONOUNCABLE? (ANABENCH) ; : ANABENCH+ ( c-addr u -- u ) ['] (PRONOUNCABLE?) IS PRONOUNCABLE? (ANABENCH) ; : ANABENCHx ( c-addr u -- u ) ['] $QUALIFY? IS PRONOUNCABLE? (ANABENCH) ; :ABOUT CR ." ( c-addr u -- ) ANAGRAMS -- Display all permutations of a string." CR ." ( c-addr1 u1 -- u2 ) ANABENCH -- count all permutations of a string." CR ." ( c-addr u -- ) ANAGRAMSx -- Display all pronouncable permutations of a string." CR ." ( c-addr1 u1 -- u2 ) ANABENCHx -- count all pronouncable permutations of a string." CR CR .~ The following table is created with: S" FORTH" ANAGRAMS~ CR CR ." FORTH FOTHR FOTRH FRHOT FRHTO FROHT FROTH FRTHO FRTOH FTHOR" CR ." FTHRO FTOHR FTORH FTRHO FTROH HFORT HFOTR HFROT HFRTO HFTOR" CR ." HFTRO HOFRT HOFTR HORFT HORTF HOTFR HOTRF HRFOT HRFTO HROFT" CR ." HROTF HRTFO HRTOF HTFOR HTFRO HTOFR HTORF HTRFO HTROF OFHRT" CR ." OFHTR OFRHT OFRTH OFTHR OFTRH OHFRT OHFTR OHRFT OHRTF OHTFR" CR ." OHTRF ORFHT ORFTH ORHFT ORHTF ORTFH ORTHF OTFHR OTFRH OTHFR" CR ." OTHRF OTRFH OTRHF RFHOT RFHTO RFOHT RFOTH RFTHO RFTOH RHFOT" CR ." RHFTO RHOFT RHOTF RHTFO RHTOF ROFHT ROFTH ROHFT ROHTF ROTFH" CR ." ROTHF RTFHO RTFOH RTHFO RTHOF RTOFH RTOHF TFHOR TFHRO TFOHR" CR ." TFORH TFRHO TFROH THFOR THFRO THOFR THORF THRFO THROF TOFHR" CR ." TOFRH TOHFR TOHRF TORFH TORHF TRFHO TRFOH TRHFO TRHOF TROFH" CR ." TROHF FHORT FHOTR FHROT FHRTO FHTOR FHTRO FOHRT FOHTR FORHT" ; .ABOUT -anagrams CR DEPRIVE (* End of Source *)