home *** CD-ROM | disk | FTP | other *** search
/ No Fragments Archive 10: Diskmags / nf_archive_10.iso / MAGS / ST_WORLD / STWORLD5.MSA / PROGRAMS_NAME_GEN_NAMEGEN.GFA (.txt) < prev    next >
GFA-BASIC Atari  |  1991-08-17  |  14KB  |  527 lines
  1. ' ********************************************************
  2. ' *********            NAME GENERATOR             ********
  3. ' ********************************************************
  4. ' *                by  Richard Karsmakers                *
  5. ' ********************************************************
  6. ' *********     Version 1.0       14-02-1990      ********
  7. ' *********     Version 1.1       22-02-1990      ********
  8. ' *********     Version 1.2       23-02-1990      ********
  9. ' *********     Version 1.3       09-03-1990      ********
  10. ' *********     Version 1.4       01-02-1991      ********
  11. ' *********     Version 1.5       20-05-1991      ********
  12. ' ********************************************************
  13. '
  14. ' Variables:      Counter%          Number of name parts
  15. '                 Used%             Number of used names
  16. '                 Another%          Number of cross list names
  17. '                 Current%          Current word
  18. '                 Name$()           Array with name parts
  19. '                 Used$()           Array with used names
  20. '                 Word$()           History of words
  21. '                 Ana%()            Anagram ascii buffer array
  22. '                 Pos$()            Array for all anagrams
  23. '                 Fac%()            Array with precalculated faculties (0-12)
  24. '                 Dummy%            Dummy variable
  25. '                 Screen$           Contains menu screen
  26. '                 Taste%            Inp(2) value for key press
  27. '                 Status$           Current word/remark, etc.
  28. '                 Seed%             Buffer for random character
  29. '                 Links$            Left part of name
  30. '                 Rechts$           Right part of name
  31. '                 Word$             Current word
  32. '                 Ownword$          Own word part
  33. '                 Fault!            Error flag
  34. '                 X%                Temporary buffer for loops
  35. '                 Lo$               Temporary Load name string
  36. '                 Buffer$()         Temporary buffer for cross lists
  37. '                 Buf$              A buffer
  38. '                 Flag!             A flag (with cross - saved or not?)
  39. '                 Anagram$          String for original Anagram word
  40. '                 Ana%              The length of Anagram$
  41. '                 Pos               Number of actually DIFFERENT anagrams possible
  42. '
  43. @check_low
  44. @load_database                     !Load database from current directory
  45. DIM word$(999)                     !History array
  46. current%=0
  47. DIM use$(999)                      !Used history array
  48. use%=0
  49. DIM ana%(25)                       !Anagram buffer array (ascii array)
  50. DIM fac%(12)                       !Prepared faculty stuff
  51. x%=0
  52. DO
  53.   READ fac%(x%)
  54.   INC x%
  55.   EXIT IF x%>12
  56. LOOP
  57. @print_menu                        !Print menu
  58. SGET screen$
  59. status$=STR$(counter%)+" name parts loaded... "+STR$(counter%*counter%)+" names possible..."
  60. DO
  61.   SPUT screen$                     !Get menu screen
  62.   PRINT AT(1,25);SPACE$((80-LEN(status$))/2);status$;
  63.   @get_key
  64.   SELECT taste%
  65.   CASE 187                         !F1
  66.     @create_name
  67.   CASE 188                         !F2
  68.     @add_name_part
  69.   CASE 189                         !F3
  70.     @cross_list
  71.   CASE 190                         !F4
  72.     @mark_as_used
  73.   CASE 191                         !F5
  74.     @cross_used_lists
  75.   CASE 192                         !F6
  76.     @history
  77.   CASE 193                         !F7
  78.     @used_history
  79.   CASE 194                         !F8
  80.     @entry
  81.   CASE 195                         !F9
  82.     @create_anagram
  83.   CASE 196                         !F10
  84.     @program_credits
  85.   CASE 27
  86.     EDIT
  87.   CASE 225
  88.     EDIT
  89.   ENDSELECT
  90.   IF taste%<187 OR taste%>196
  91.     seed%=RANDOM(5)
  92.     SELECT seed%
  93.     CASE 0
  94.       status$="Why do you press a key that isn't valid? Are you a nurd?"
  95.     CASE 1
  96.       status$="You must be the doofest creature on earth...that key is non-valid!"
  97.     CASE 2
  98.       status$="Keep your hands off the wrong keys, man! Are you a fuckin' sexist?!"
  99.     CASE 3
  100.       status$="Sir, I am afraid this in a key which beliefs it is a non-entity..."
  101.     CASE 4
  102.       status$="Try something better to make this program crash, potatobrain!"
  103.     ENDSELECT
  104.   ENDIF
  105. LOOP
  106. '
  107. PROCEDURE check_low
  108.   IF XBIOS(2)=0                    !Low resolution?
  109.     ALERT 1,"NO LOW RES SUPPORT!",1,"SHIT!",dummy%
  110.     EDIT
  111.   ENDIF
  112. RETURN
  113. '
  114. PROCEDURE load_database
  115.   DIM naam$(999)                   !1000 slots for names
  116.   DIM used$(999)                   !1000 slots for used names
  117.   OPEN "I",#1,"NAMES.TXT"          !Open file NAMES.TXT for input
  118.   counter%=0                       !Start reading at first slot
  119.   WHILE NOT EOF(#1)                !While end of file not reached
  120.     INPUT #1,naam$(counter%)       !Get name
  121.     naam$(counter%)=UPPER$(naam$(counter%))
  122.     INC counter%                   !Prepare counter for next slot
  123.   WEND                             !Wend
  124.   CLOSE #1
  125.   IF EXIST("USED.TXT")             !Already filenames used?
  126.     OPEN "I",#1,"USED.TXT"         !Open file NAMES.TXT for input
  127.     used%=0                        !Start reading at first slot
  128.     WHILE NOT EOF(#1)              !While end of file not reached
  129.       INPUT #1,used$(used%)        !Get name
  130.       used$(used%)=UPPER$(used$(used%))
  131.       INC used%                    !Prepare counter for next slot
  132.     WEND                           !Wend
  133.     CLOSE #1
  134.   ELSE
  135.     used%=1
  136.   ENDIF
  137. RETURN
  138. '
  139. PROCEDURE print_menu
  140.   CLS                              !Clear the screen
  141.   @on
  142.   PRINT SPACE$(80);
  143.   PRINT SPACE$(80);
  144.   PRINT SPACE$(80);
  145.   PRINT SPACE$(80);
  146.   PRINT SPACE$(30);"NAME GENERATOR  V1.5";SPACE$(30)
  147.   @off
  148.   PRINT
  149.   PRINT
  150.   PRINT SPACE$(20);"F 1  ----------------------  Create name"
  151.   PRINT SPACE$(20);"F 2  --------------------  Add name part"
  152.   PRINT SPACE$(20);"F 3  -------------  Cross name part list"
  153.   PRINT SPACE$(20);"F 4  ---------------------  Mark as used"
  154.   PRINT SPACE$(20);"F 5  -----------------  Cross used lists"
  155.   PRINT SPACE$(20);"F 6  -----------------  Creation history"
  156.   PRINT SPACE$(20);"F 7  ---------------------  Used history"
  157.   PRINT SPACE$(20);"F 8  --------  Delete entries from lists"
  158.   PRINT SPACE$(20);"F 9  -------------------  Create anagram"
  159.   PRINT SPACE$(20);"F10  ------------------  Program credits"
  160.   PRINT
  161.   PRINT
  162.   PRINT SPACE$(26);"(Press ESC or UNDO to quit!)"
  163.   @on
  164.   PRINT SPACE$(80);
  165.   PRINT SPACE$(80);
  166.   PRINT SPACE$(80);
  167.   @off
  168. RETURN
  169. '
  170. PROCEDURE on
  171.   PRINT CHR$(27);"p";              !Reverse video on
  172. RETURN
  173. '
  174. PROCEDURE off
  175.   IF XBIOS(4)=2                    !High resolution
  176.     PRINT CHR$(27);"q";            !Reverse video off
  177.   ELSE
  178.     PRINT CHR$(27);"q"             !Reverse video off
  179.   ENDIF
  180. RETURN
  181. '
  182. PROCEDURE create_name
  183.   ' get two random name parts, tie them together
  184.   seed%=RANDOM(counter%)
  185.   links$=naam$(seed%)
  186.   REPEAT
  187.     seed%=RANDOM(counter%)
  188.     rechts$=naam$(seed%)
  189.   UNTIL links$<>rechts$
  190.   word$=links$+rechts$
  191.   status$=word$
  192.   word$(current%)=word$
  193.   INC current%
  194. RETURN
  195. '
  196. PROCEDURE add_name_part
  197.   ' Add name part, save to disk
  198.   CLS
  199.   INPUT "Enter the name part ";ownword$
  200.   ownword$=UPPER$(ownword$)
  201.   @namealready
  202.   IF fault!
  203.     status$="Name part already present! Not used!"
  204.   ELSE
  205.     naam$(counter%)=ownword$
  206.     INC counter%
  207.     OPEN "O",#1,"NAMES.TXT"
  208.     x%=0
  209.     REPEAT
  210.       PRINT #1;naam$(x%)
  211.       INC x%
  212.     UNTIL x%=counter%
  213.     CLOSE #1
  214.     status$="Name part added to list!"
  215.   ENDIF
  216. RETURN
  217. '
  218. PROCEDURE cross_list
  219.   ' load in other base, cross them (do not include doubles!)
  220.   buf$=ownword$
  221.   ERASE buffer$()
  222.   DIM buffer$(999)
  223.   FILESELECT "*.TXT","",lo$
  224.   IF EXIST(lo$)
  225.     OPEN "I",#1,lo$                !Open file for input
  226.     another%=0                     !Start reading at first slot
  227.     WHILE NOT EOF(#1)              !While end of file not reached
  228.       INPUT #1,buffer$(another%)   !Get name
  229.       buffer$(another%)=UPPER$(buffer$(another%))
  230.       INC another%                 !Prepare counter for next slot
  231.     WEND                           !Wend
  232.     CLOSE #1
  233.     x%=0
  234.     flag!=FALSE
  235.     REPEAT
  236.       ownword$=buffer$(x%)
  237.       @namealready                 !Exists already?
  238.       IF fault!=FALSE              !Negative!
  239.         naam$(counter%)=ownword$   !Add it!
  240.         INC counter%
  241.         flag!=TRUE                 !Set flag to save new list later
  242.       ENDIF
  243.       INC x%
  244.     UNTIL x%=another%
  245.     IF flag!                       !Words were added!
  246.       OPEN "O",#1,"NAMES.TXT"      !Save the file!
  247.       x%=0
  248.       REPEAT
  249.         PRINT #1;naam$(x%)
  250.         INC x%
  251.       UNTIL x%=counter%
  252.       CLOSE #1
  253.       status$="Names added and file saved!"
  254.     ELSE                              !No words were added!
  255.       status$="No new name parts found...nothing added!"
  256.     ENDIF
  257.   ELSE
  258.     ALERT 1,"FILE NOT FOUND!",1,"TAUB!",dummy%
  259.     status$="Something went wrong!"
  260.   ENDIF
  261.   ownword$=buf$
  262. RETURN
  263. '
  264. PROCEDURE mark_as_used
  265.   ' compare old used list with word....when not found, mark as used
  266.   LOCAL x%
  267.   IF word$<>""
  268.     @usedalready
  269.   ELSE
  270.     fault!=TRUE
  271.   ENDIF
  272.   IF fault!
  273.     status$="Word was already used before!!"
  274.   ELSE
  275.     used$(used%)=word$
  276.     INC used%
  277.     OPEN "O",#1,"USED.TXT"
  278.     x%=0
  279.     REPEAT
  280.       PRINT #1;used$(x%)
  281.       INC x%
  282.     UNTIL x%=used%
  283.     CLOSE #1
  284.     status$="Name '"+word$+"' marked as 'used'!"
  285.     use$(use%)=word$
  286.     INC use%
  287.   ENDIF
  288. RETURN
  289. '
  290. PROCEDURE cross_used_lists
  291.   buf$=word$
  292.   ERASE buffer$()
  293.   DIM buffer$(999)
  294.   FILESELECT "*.TXT","",lo$
  295.   IF EXIST(lo$)
  296.     OPEN "I",#1,lo$                !Open file for input
  297.     another%=0                     !Start reading at first slot
  298.     WHILE NOT EOF(#1)              !While end of file not reached
  299.       INPUT #1,buffer$(another%)   !Get name
  300.       buffer$(another%)=UPPER$(buffer$(another%))
  301.       INC another%                 !Prepare counter for next slot
  302.     WEND                           !Wend
  303.     CLOSE #1
  304.     x%=0
  305.     flag!=FALSE
  306.     REPEAT
  307.       word$=buffer$(x%)
  308.       @usedalready                 !Exists already?
  309.       IF fault!=FALSE              !Negative!
  310.         used$(used%)=word$         !Add it!
  311.         INC used%
  312.         flag!=TRUE                 !Set flag to save new list later
  313.       ENDIF
  314.       INC x%
  315.     UNTIL x%=another%
  316.     IF flag!                       !Words were added!
  317.       OPEN "O",#1,"USED.TXT"      !Save the file!
  318.       x%=0
  319.       REPEAT
  320.         PRINT #1;used$(x%)
  321.         INC x%
  322.       UNTIL x%=used%
  323.       CLOSE #1
  324.       status$="Names added and new 'used' file saved!"
  325.     ELSE                              !No words were added!
  326.       status$="No new used names found...nothing added!"
  327.     ENDIF
  328.   ELSE
  329.     ALERT 1,"FILE NOT FOUND!",1,"TAUB!",dummy%
  330.     status$="Something went wrong!"
  331.   ENDIF
  332.   word$=buf$
  333. RETURN
  334. '
  335. PROCEDURE history
  336.   IF current%<>0
  337.     CLS
  338.     x%=0
  339.     REPEAT
  340.       PRINT SPACE$(40-(LEN(word$(x%)))/2);word$(x%)
  341.       INC x%
  342.       IF INP?(2)
  343.         PRINT
  344.         PRINT SPACE$(30);"Hit a key to continue..."
  345.         @get_key
  346.       ENDIF
  347.     UNTIL x%=current%+1
  348.     @get_key
  349.     status$="That was interesting, wasn't it?"
  350.   ELSE
  351.     status$="No History in this session yet!"
  352.   ENDIF
  353.   taste%=190
  354. RETURN
  355. '
  356. PROCEDURE used_history
  357.   IF use%<>0
  358.     CLS
  359.     PRINT "Screen or printer? (S/P)"
  360.     @get_key
  361.     IF taste%<>112 AND taste%<>80   !No 'P' pressed
  362.       x%=0
  363.       REPEAT
  364.         PRINT SPACE$(40-(LEN(use$(x%)))/2);use$(x%)
  365.         INC x%
  366.         IF INP?(2)
  367.           PRINT
  368.           PRINT SPACE$(30);"Hit a key to continue..."
  369.           @get_key
  370.         ENDIF
  371.       UNTIL x%=use%+1
  372.       @get_key
  373.       status$="That was a really interesting list of GREAT words, don't you agree?"
  374.     ELSE
  375.       IF GEMDOS(17)=0                 !Check if printer on
  376.         ALERT 1,"NO PRINTER THERE!",1,"WHAT?!",dummy%
  377.         status$="You tried to print the 'Used History' shit, but without printer..."
  378.       ELSE
  379.         x%=0
  380.         REPEAT
  381.           LPRINT use$(x%),
  382.           INC x%
  383.         UNTIL x%=use%+1
  384.         status$="You just printed the 'Used History' shit!"
  385.       ENDIF
  386.     ENDIF
  387.   ELSE
  388.     status$="No names used in this session yet!"
  389.   ENDIF
  390.   taste%=190
  391. RETURN
  392. '
  393. PROCEDURE entry
  394.   CLS
  395.   PRINT
  396.   PRINT
  397.   PRINT
  398.   PRINT
  399.   PRINT
  400.   @on
  401.   PRINT "  Use TEMPUS or another editor to delete the lines in the corresponding files  ";
  402.   PRINT SPACE$(7);"NAMES.TXT contains the word parts; USED.TXT contains the used words";SPACE$(7);
  403.   PRINT SPACE$(14);"Do not forget to save the files back as ASCII file!!";SPACE$(14)
  404.   @off
  405.   @get_key
  406.   taste%=190
  407. RETURN
  408. '
  409. PROCEDURE create_anagram
  410.   ' This routine has not yet been entirely coded.
  411.   ' Enough feedback will get it coded. If you want to code it, feel free!
  412.   ' If you send that version than I will credit you there!
  413.   CLS
  414.   @on
  415.   PRINT " Anagram Creator. Tnx to Nic. Enter max. 12 characters (NO NUMERALS!)";SPACE$(11)
  416.   @off
  417.   DO
  418.     INPUT " Name to create anagram of : ",anagram$
  419.     ana%=LEN(anagram$)
  420.     EXIT IF ana%<13 AND ana%<>0
  421.   LOOP
  422.   anagram$=UPPER$(anagram$)
  423.   ARRAYFILL ana%(),0
  424.   x%=1
  425.   DO
  426.     INC ana%(ASC(MID$(anagram$,x%,1))-65)   !Analyse character occurence
  427.     INC x%
  428.     EXIT IF x%>ana%
  429.   LOOP
  430.   pos#=1
  431.   x%=0
  432.   DO                                        !Calculate possibilities
  433.     pos#=pos#*fac%(ana%(x%))
  434.     INC x%
  435.     EXIT IF x%>25
  436.   LOOP
  437.   pos#=1/(pos#/fac%(ana%))
  438.   PRINT " Number of possibilities   : ";pos#
  439.   ERASE pos$()
  440.   DIM pos$(pos#)                             !Create array for possible words
  441.   x%=1
  442.   DO
  443.     ' Create anagram
  444.     ' Check validity
  445.     IF fac%(ana%)<>pos#
  446.       ' Check if already used before (only if there are double chars)
  447.     ENDIF
  448.     INC x%
  449.     EXIT IF x%>pos#
  450.   LOOP
  451.   PRINT
  452.   PRINT " Hit any key to continue!"
  453.   @get_key
  454.   taste%=190
  455. RETURN
  456. '
  457. PROCEDURE program_credits
  458.   CLS
  459.   dummy%=PEEK(16745024)
  460.   SPOKE 16745024,0
  461.   PRINT " Why, for heaven's sake, do you wish to have a look at the program credits? Is"
  462.   PRINT "it of any importance to you? Well, I guess it isn't. However, since I am a"
  463.   PRINT "bleedin' egomaniac that thrives on getting famous, I will honour you with the"
  464.   PRINT "required information anyway - also because I really do not want to do anything"
  465.   PRINT "else at this moment (which is the moment on which I am programming this shit)."
  466.   PRINT " It will probably not be of any importance for you to know that I am right now"
  467.   PRINT "listening to Iron Maiden and gently moving my head back and forth on the rhythm"
  468.   PRINT "of the sounds coming from my headphones. But I told you this for precisely the"
  469.   PRINT "same reasons as those because of which I will soon tell you who I am. I hope"
  470.   PRINT "you haven't read the status line in the previous menu screen, yet, 'cause that"
  471.   PRINT "will then most likely spoil all your fun."
  472.   PRINT " Well, well."
  473.   PRINT " When I started writing this text, I decided that it had to be one full page"
  474.   PRINT "in bloody length - and this at ANY costs. So I guess I can write a bit more,"
  475.   PRINT "since there are still a couple of lines left. Do you also notice that everything";
  476.   PRINT "I have written here uptil now is sheer BULLSHIT?"
  477.   PRINT " I am glad you did, for otherwise you're even more stupid than I fuckin'"
  478.   PRINT "thought. So I guess you're not as bad at all, and therefore I will honour thee"
  479.   PRINT "with letting you know who the fuck I am. Yeah......who IS that fuckin' lunatic"
  480.   PRINT "that keeps on fuckin' abusing the fuckin' English language by using a whole"
  481.   PRINT "fuckin' lot of fuckin' fuckin'? Well....it is the fuckin' author of this fuckin'";
  482.   PRINT "program and he is fuckin' called Richard (Yeah! Right fuckin' on!)."
  483.   PRINT
  484.   PRINT " Sorry for this blatant abuse of the English language, folx!"
  485.   status$="You just had a look at those stupid program credits..."
  486.   @get_key
  487.   taste%=196
  488.   SPOKE 16745024,dummy%
  489. RETURN
  490. '
  491. PROCEDURE get_key
  492.   LPOKE XBIOS(14,1)+6,0      !Clear keyboard buffer
  493.   taste%=INP(2)
  494. RETURN
  495. '
  496. PROCEDURE namealready
  497.   ' This routine checks if a word already exists in the NAAM$()
  498.   ' returns a fault! is true when found
  499.   LOCAL x%
  500.   x%=0
  501.   fault!=FALSE
  502.   REPEAT
  503.     IF ownword$=naam$(x%)
  504.       fault!=TRUE
  505.     ENDIF
  506.     INC x%
  507.   UNTIL fault!=TRUE OR x%=counter%
  508. RETURN
  509. '
  510. PROCEDURE usedalready
  511.   ' This routine checks if a word already exists in the USED$()
  512.   ' returns a fault! is true when found
  513.   LOCAL x%
  514.   x%=0
  515.   fault!=FALSE
  516.   REPEAT
  517.     IF word$=used$(x%)
  518.       fault!=TRUE
  519.     ENDIF
  520.     INC x%
  521.   UNTIL fault!=TRUE OR x%=used%
  522. RETURN
  523. '
  524. ' Precalculated faculty shit
  525. '
  526. DATA 1,1,2,6,24,120,720,5040,40320,362880,3628800,39916800,479001600
  527.