'Program to generate "sentences" random

User projects written in or related to FreeBASIC.
lrcvs
Posts: 576
Joined: Mar 06, 2008 19:27
Location: Spain

'Program to generate "sentences" random

Postby lrcvs » Mar 07, 2010 22:11

Code: Select all

'Program to generate "sentences" random
'lrcvs 20.08.09

'Possible uses:
'to sort files
'fill arrays....

dim as integer h,j,l,a,b,n
dim as string z, y, k

CLS
FOR h = 1 TO 100 '<<< Number of sentences
l = 10 '<<< Number of words
j = 0
    WHILE j < l
    z = ""
    RANDOMIZE val(right$(ltrim$(str$(timer)),3))
    a = INT(RND * 100)
    IF a > 64 THEN b = a
    IF b < 91 THEN c = b
    IF a > 64 AND b < 91 THEN z$ = str$(CHR$(b)): y = z
        FOR n = 1 TO 10
        RANDOMIZE val(right$(ltrim$(str$(timer)),3))
        a = INT(RND * 100)
        IF a > 64 THEN b = a
        IF b < 91 THEN c = b
        IF a > 64 AND b < 91 THEN z = z + str(CHR$ (b))
        NEXT n
    k = k + z + " "
    j = j + 1
    IF LEFT$(k, 1) = " " THEN MID$(k, 1) = y
    WEND
PRINT k
k = ""
NEXT h
sleep
END

duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Postby duke4e » Mar 07, 2010 22:35

This better?

Code: Select all

' http://www.darkicon.com/lovecraft.htm

#Define False 0
#Define True NOT False

Randomize Timer

' The following are used to greatly reduce the incidence of repeated words in a sentence...
Dim Shared As Integer PrevNoun = -1
Dim Shared As Integer PrevTransitiveVerb = -1
Dim Shared As Integer PrevIntransitiveVerb = -1
Dim Shared As Integer PrevAdjective = -1
Dim Shared As Integer PrevAdverb = -1
Dim Shared As Integer FirstSentence = True

' Then call qrand(n) to generate a random number from 0 to n-1.
Function qrand(n As Integer) As Integer
    Return Int(Rnd * n)
End Function

Function CapFirst(s As String) As String
    Return Ucase(Mid(s, 1, 1)) + Mid(s, 2, Len(s) - 1)
End Function

Function GenRandomSentenceTemplate() As String
    ' 0 = lone noun
    ' 1 = noun phrase
    ' 2 = transitive verb phrase (past tense, singular, third person)
    ' 3 = conjunction
    ' 4 = intransitive verb phrase
    ' 5 = transitive verb phrase (infinitive, singular)
    ' 6 = adjective
    ' 7 = adverb
   
    Dim As String w
    Dim As Integer n = 20
    Dim As Integer r = qrand(n + 5)
   
    If r > n Then w = "1 2 1."
    If r = 1 Then w = "1 2 1, 3 1 2 1."
    If r = 2 Then w = "When 1 4, 1 4."
    If r = 3 Then w = "If 1 2 1, then 1 4."
    If r = 4 Then w = "Sometimes 1 4, but soon I was to find that 1 always 2 1!"
    If r = 5 Then w = "Most people believe that 1 2 1, but the 6 0 is much  more 6."
    If r = 6 Then w = "I watched in horror as 1 7 2 the 0!"
    If r = 7 Then w = "1 4, 3 1 2 1."
    If r = 8 Then w = "Oh, the 6 0 of it ALL!"
    If r = 9 Then w = "It took no 6 0 to make me 7 5 1, but the 6 0 was 6."
    If r = 10 Then
        If FirstSentence Then w = "1 2 1, 3 1 2 7 6 0." Else w = "Indeed, the 6 0 of 1 was 6."
    End If
    If r = 11 Then
        If FirstSentence Then w = "1 2 7 6 0." Else w = "Furthermore, 1 4, and 1 2 1."
    End If
    If r = 12 Then
        If FirstSentence Then w = "1 2 6 0." Else w = "For example, 1 indicates that 1 2 1."
    End If
    If r = 13 Then w = "When you see 1, it means that 1 4."
    If r = 14 Then w = "Remembering the 6 0 of 1, I prostated myself before the 0 of the 1 that stood before me."
    If r = 15 Then w = "1 was 6."
    If r = 16 Then w = "When 1 is 6, 1 2 1."
    If r = 17 Then w = "At long last, the 6 0 of the 6, 6 0 was revealed!"
    If r = 18 Then w = "It was 1, but now I had no choice but to accept the fact that 1 was indeed 6 as well as 7 6!"
    If r = 19 Then w = "Like a 7 6 1 they 2 0, some 6, but others 7 or 7 2 1."
   
    FirstSentence = False
    Return w
End Function


Function GenNoun() As String
    Dim As Integer n = 130
    Dim As Integer r = qrand(n)
    Dim As String w
   
    Do
        r = qrand(n)
    Loop Until r <> PrevNoun
    PrevNoun = r
   
    If r = 0 Then w = "darkness"
    If r = 1 Then w = "blackness"
    If r = 2 Then w = "abstraction"
    If r = 3 Then w = "pyramid"
    If r = 4 Then w = "monstrosity"
    If r = 5 Then w = "death"
    If r = 6 Then w = "annihilation"
    If r = 7 Then w = "insignificance"
    If r = 8 Then w = "wheel"
    If r = 9 Then w = "terror"
    If r = 10 Then w = "horror"
    If r = 11 Then w = "squid"
    If r = 12 Then w = "tripod"
    If r = 13 Then w = "scout"
    If r = 14 Then w = "bulb"
    If r = 15 Then w = "hole"
    If r = 16 Then w = "soil"
    If r = 17 Then w = "submarine"
    If r = 18 Then w = "insanity"
    If r = 19 Then w = "tape recorder"
    If r = 20 Then w = "anomaly"
    If r = 21 Then w = "sanity"
    If r = 22 Then w = "mortician"
    If r = 23 Then w = "fire"
    If r = 24 Then w = "Elder Sign"
    If r = 25 Then w = "torch"
    If r = 26 Then w = "tome"
    If r = 27 Then w = "splendor"
    If r = 28 Then w = "township"
    If r = 29 Then w = "transformation"
    If r = 30 Then w = "color"
    If r = 31 Then w = "shadow"
    If r = 32 Then w = "estate"
    If r = 33 Then w = "surface"
    If r = 34 Then w = "recording"
    If r = 35 Then w = "ocean"
    If r = 36 Then w = "creature"
    If r = 37 Then w = "thing"
    If r = 38 Then w = "ritual"
    If r = 39 Then w = "book"
    If r = 40 Then w = "manuscript"
    If r = 41 Then w = "science"
    If r = 42 Then w = "Necronomicon"
    If r = 43 Then w = "knowledge"
    If r = 44 Then w = "servant"
    If r = 45 Then w = "automobile"
    If r = 46 Then w = "brain"
    If r = 47 Then w = "echo"
    If r = 48 Then w = "paralysis"
    If r = 49 Then w = "clock"
    If r = 50 Then w = "vapour"
    If r = 51 Then w = "beam"
    If r = 52 Then w = "lantern"
    If r = 53 Then w = "abyss"
    If r = 54 Then w = "scream"
    If r = 55 Then w = "nation"
    If r = 56 Then w = "symmetry"
    If r = 57 Then w = "phantasm"
    If r = 58 Then w = "source"
    If r = 59 Then w = "history"
    If r = 60 Then w = "legend"
    If r = 61 Then w = "doorstep"
    If r = 62 Then w = "nightmare"
    If r = 63 Then w = "rock"
    If r = 64 Then w = "globule"
    If r = 65 Then w = "bargain"
    If r = 66 Then w = "note"
    If r = 67 Then w = "figure"
    If r = 68 Then w = "fascination"
    If r = 69 Then w = "occurance"
    If r = 70 Then w = "coffin"
    If r = 71 Then w = "vault"
    If r = 72 Then w = "model"
    If r = 73 Then w = "ghoul"
    If r = 74 Then w = "burden"
    If r = 75 Then w = "vacuum"
    If r = 76 Then w = "lover"
    If r = 77 Then w = "void"
    If r = 78 Then w = "stone"
    If r = 79 Then w = "pit"
    If r = 80 Then w = "vista"
    If r = 81 Then w = "voice"
    If r = 82 Then w = "ooze"
    If r = 83 Then w = "building"
    If r = 84 Then w = "monolith"
    If r = 85 Then w = "inferiority"
    If r = 86 Then w = "delicacy"
    If r = 87 Then w = "memory"
    If r = 88 Then w = "library"
    If r = 89 Then w = "fear"
    If r = 90 Then w = "aversion"
    If r = 91 Then w = "existence"
    If r = 92 Then w = "speech"
    If r = 93 Then w = "tomb"
    If r = 94 Then w = "blood clot"
    If r = 95 Then w = "ring"
    If r = 96 Then w = "spirit"
    If r = 97 Then w = "abnormality"
    If r = 98 Then w = "secret"
    If r = 99 Then w = "mark"
    If r = 100 Then w = "mulch"
    If r = 101 Then w = "viper"
    If r = 102 Then w = "case"
    If r = 103 Then w = "mushroom"
    If r = 104 Then w = "engine"
    If r = 105 Then w = "column"
    If r = 106 Then w = "arch"
    If r = 107 Then w = "truck"
    If r = 108 Then w = "germ"
    If r = 109 Then w = "egg"
    If r = 110 Then w = "myth"
    If r = 111 Then w = "statue"
    If r = 112 Then w = "war"
    If r = 113 Then w = "organism"
    If r = 114 Then w = "empty lot"
    If r = 115 Then w = "demon"
    If r = 116 Then w = "table"
    If r = 117 Then w = "particle"
    If r = 118 Then w = "cloud formation"
    If r = 119 Then w = "coin"
    If r = 120 Then w = "burglar"
    If r = 121 Then w = "spider"
    If r = 122 Then w = "symbol"
    If r = 123 Then w = "satellite"
    If r = 124 Then w = "scythe"
    If r = 125 Then w = "canyon"
    If r = 126 Then w = "polygon"
    If r = 127 Then w = "crane"
    If r = 128 Then w = "wedge"
    If r = 129 Then w = "fraction"
   
    Return w
End Function


Function GenPreposition() As String
    Dim As Integer n = 15
    Dim As Integer r = qrand(n)
    Dim As String w
   
    If r = 0 Then w = "of"
    If r = 1 Then w = "from"
    If r = 2 Then w = "near"
    If r = 3 Then w = "about"
    If r = 4 Then w = "around"
    If r = 5 Then w = "for"
    If r = 6 Then w = "toward"
    If r = 7 Then w = "over"
    If r = 8 Then w = "behind"
    If r = 9 Then w = "beyond"
    If r = 10 Then w = "related to"
    If r = 11 Then w = "out of"
    If r = 12 Then w = "inside"
    If r = 13 Then w = "living inside"
    If r = 14 Then w = "beneath"
   
    Return w
End Function


Function GenAdverb() As String
    Dim As Integer n = 29
    Dim As Integer r = qrand(n)
    Dim As String s
   
    Do
        r = qrand(n)
    Loop Until r <> PrevAdverb
    PrevAdverb = r
   
    If r = 0 Then s = "knowingly"
    If r = 1 Then s = "frantically"
    If r = 2 Then s = "greedily"
    If r = 3 Then s = "hesitantly"
    If r = 4 Then s = "secretly"
    If r = 5 Then s = "carelessly"
    If r = 6 Then s = "thoroughly"
    If r = 7 Then s = "barely"
    If r = 8 Then s = "ridiculously"
    If r = 9 Then s = "non-chalantly"
    If r = 10 Then s = "hardly"
    If r = 11 Then s = "eagerly"
    If r = 12 Then s = "feverishly"
    If r = 13 Then s = "lazily"
    If r = 14 Then s = "inexorably"
    If r = 15 Then s = "accurately"
    If r = 16 Then s = "accidentally"
    If r = 17 Then s = "completely"
    If r = 18 Then s = "usually"
    If r = 19 Then s = "single-handledly"
    If r = 20 Then s = "underhandedly"
    If r = 21 Then s = "almost"
    If r = 22 Then s = "wisely"
    If r = 23 Then s = "ostensibly"
    If r = 24 Then s = "somewhat"
    If r = 25 Then s = "overwhelmingly"
    If r = 26 Then s = "seldom"
    If r = 27 Then s = "often"
    If r = 28 Then s = "unwittingly"
   
    Return s
End Function


Function GenAdjective() As String
    Dim As Integer n = 119
    Dim As Integer r = qrand(n)
    Dim As String w
   
    Do
        r = qrand(n)
    Loop Until r <> PrevAdjective
    PrevAdjective = r
   
    If r = 0 Then w = "slow"
    If r = 1 Then w = "surly"
    If r = 2 Then w = "eldritch"
    If r = 3 Then w = "putrid"
    If r = 4 Then w = "treacherous"
    If r = 5 Then w = "cyclopian"
    If r = 6 Then w = "smelly"
    If r = 7 Then w = "non-euclidian"
    If r = 8 Then w = "annoying"
    If r = 9 Then w = "burly"
    If r = 10 Then w = "raspy"
    If r = 11 Then w = "moldy"
    If r = 12 Then w = "blotched"
    If r = 13 Then w = "indescribable"
    If r = 14 Then w = "excessive"
    If r = 15 Then w = "magnificent"
    If r = 16 Then w = "ancient"
    If r = 17 Then w = "cylindrical"
    If r = 18 Then w = "unearthly"
    If r = 19 Then w = "notable"
    If r = 20 Then w = "revered"
    If r = 21 Then w = "broken"
    If r = 22 Then w = "righteous"
    If r = 23 Then w = "mysterious"
    If r = 24 Then w = "bizarre"
    If r = 25 Then w = "irregular"
    If r = 26 Then w = "college-educated"
    If r = 27 Then w = "bohemian"
    If r = 28 Then w = "statesmanlike"
    If r = 29 Then w = "stoic"
    If r = 30 Then w = "hypnotic"
    If r = 31 Then w = "dirt-encrusted"
    If r = 32 Then w = "purple"
    If r = 33 Then w = "infected"
    If r = 34 Then w = "infinite"
    If r = 35 Then w = "tattered"
    If r = 36 Then w = "opulent"
    If r = 37 Then w = "modern"
    If r = 38 Then w = "exceedingly strange"
    If r = 39 Then w = "self-loathing"
    If r = 40 Then w = "frustrating"
    If r = 41 Then w = "terrible"
    If r = 42 Then w = "subconscious"
    If r = 43 Then w = "impromptu"
    If r = 44 Then w = "makeshift"
    If r = 45 Then w = "so-called"
    If r = 46 Then w = "proverbial"
    If r = 47 Then w = "molten"
    If r = 48 Then w = "cryptic"
    If r = 49 Then w = "psychotic"
    If r = 50 Then w = "foreign"
    If r = 51 Then w = "unfamiliar"
    If r = 52 Then w = "iridescent"
    If r = 53 Then w = "precise"
    If r = 54 Then w = "inhuman"
    If r = 55 Then w = "horrible"
    If r = 56 Then w = "cold"
    If r = 57 Then w = "blasphemous"
    If r = 58 Then w = "false"
    If r = 59 Then w = "hideous"
    If r = 60 Then w = "temporal"
    If r = 61 Then w = "fractured"
    If r = 62 Then w = "dreamlike"
    If r = 63 Then w = "imaginative"
    If r = 64 Then w = "earth-threatening"
    If r = 65 Then w = "memorable"
    If r = 66 Then w = "twisted"
    If r = 67 Then w = "unbearable"
    If r = 68 Then w = "orbiting"
    If r = 69 Then w = "unspeakable"
    If r = 70 Then w = "unstable"
    If r = 71 Then w = "outer"
    If r = 72 Then w = "nearest"
    If r = 73 Then w = "unimaginable"
    If r = 74 Then w = "human"
    If r = 75 Then w = "shocking"
    If r = 76 Then w = "evil"
    If r = 77 Then w = "anotomical"
    If r = 78 Then w = "dripping"
    If r = 79 Then w = "salty"
    If r = 80 Then w = "reptilian-looking"
    If r = 81 Then w = "hellish"
    If r = 82 Then w = "cosmic"
    If r = 83 Then w = "frozen"
    If r = 84 Then w = "curious"
    If r = 85 Then w = "incinerated"
    If r = 86 Then w = "vaporized"
    If r = 87 Then w = "abnormal"
    If r = 88 Then w = "paternal"
    If r = 89 Then w = "childlike"
    If r = 90 Then w = "typical"
    If r = 91 Then w = "damp"
    If r = 92 Then w = "impossible"
    If r = 93 Then w = "green"
    If r = 94 Then w = "dreaded"
    If r = 95 Then w = "frightening"
    If r = 96 Then w = "living"
    If r = 97 Then w = "resplendent"
    If r = 98 Then w = "devilish"
    If r = 99 Then w = "earthy"
    If r = 100 Then w = "half-hidden"
    If r = 101 Then w = "vile"
    If r = 102 Then w = "mouldering"
    If r = 103 Then w = "furtive"
    If r = 104 Then w = "geological"
    If r = 105 Then w = "fungoid"
    If r = 106 Then w = "nameless"
    If r = 107 Then w = "lethal"
    If r = 108 Then w = "ancestral"
    If r = 109 Then w = "obscure"
    If r = 110 Then w = "grotesque"
    If r = 111 Then w = "ghastly"
    If r = 112 Then w = "insidious"
    If r = 113 Then w = "antiquarian"
    If r = 114 Then w = "geneological"
    If r = 115 Then w = "febrile"
    If r = 116 Then w = "unfathomed"
    If r = 117 Then w = "inconceivable"
    If r = 118 Then w = "amphibian"
   
    If qrand(10) > 7 Then w = GenAdverb() + " " + w
   
    Return w
End Function

Function GenNounPhrase(depth As Integer) As String
    Dim As Integer phraseKind = qrand(3)
    Dim As String s
   
    If phraseKind = 0 Or depth > 0 Then s = GenNoun()
    If phraseKind = 1 Then s = GenAdjective() + " " + GenNoun()
    If phraseKind = 2 Then s = GenNoun() + " " + GenPreposition() + " " + GenNounPhrase(depth + 1)
   
    Dim As Integer r = qrand(100)
    If r < 30 Then
        s = "the " + s
    Elseif r < 35 Then
        s = "another " + s
    Elseif r < 40 Then
        s = "some " + s
    Else
        Dim As String c = Left(s, 1)
        If (Left(s, 8) <> "Eurasian") And (c = "a" Or c = "e" Or c = "i" Or c = "o" Or c = "u") Then s = "an " + s Else s = "a " + s
    End If
   
    Return s
End Function


Function GenTransitiveVerbPhrase(tense As Integer) As String
    ' 0 = infinitive
    ' 1 = past tense, third person singular
   
    Dim As Integer n = 56
    Dim As Integer r = qrand(n)
    Dim As String s
   
    Do
        r = qrand(n)
    Loop Until r <> PrevTransitiveVerb
    PrevTransitiveVerb = r
   
    If r = 0 Then s = "engulfe$"
    If r = 1 Then s = "conquere$"
    If r = 2 Then s = "consume$"
    If r = 3 Then s = "explore$"
    If r = 4 Then s = "learn*"
    If r = 5 Then s = "suck* the life from"
    If r = 6 Then s = "unleash* its power upon"
    If r = 7 Then s = "devour*"
    If r = 8 Then s = "seek$"
    If r = 9 Then s = "ignore$"
    If r = 10 Then s = "dance$ with"
    If r = 11 Then s = "recognize$"
    If r = 12 Then s = "compete$ with"
    If r = 13 Then s = "reach* an understanding with"
    If r = 14 Then s = "negotiate$ with"
    If r = 15 Then s = "assimilate$"
    If r = 16 Then s = "bestow* great honor upon"
    If r = 17 Then s = "derive$ perverse pleasure from"
    If r = 18 Then s = "secret* away the awful knowledge of"
    If r = 19 Then s = "seduce$"
    If r = 20 Then s = "summon*"
    If r = 21 Then s = "disturb*"
    If r = 22 Then s = "laugh* in the face of"
    If r = 23 Then s = "befriend*"
    If r = 24 Then s = "form* an uncomfortable alliance with"
    If r = 25 Then s = "barter* " + GenNounPhrase(0) + " in exchange for"
    If r = 26 Then s = "brainwash*"
    If r = 27 Then s = "trade$"
    If r = 28 Then s = "help* contain the"
    If r = 29 Then s = "faint* at the very thought of"
    If r = 30 Then s = "clean*"
    If r = 31 Then s = "satiate$"
    If r = 32 Then s = "re-animate$"
    If r = 33 Then s = "explian*"
    If r = 34 Then s = "lecture$ at long length about"
    If r = 35 Then s = "pierce$ the black, beating heart of"
    If r = 36 Then s = "play* horrible games with"
    If r = 37 Then s = "bump* accidentally into"
    If r = 38 Then s = "share$ its power with"
    If r = 39 Then s = "grant* the power of"
    If r = 40 Then s = "cook* and ate the flesh of"
    If r = 41 Then s = "peek* at"
    If r = 42 Then s = "place$ the sacred mark of Cthulhu upon"
    If r = 43 Then s = "view* the hideous offspring of"
    If r = 44 Then s = "hate$"
    If r = 45 Then s = "avoid* contact with"
    If r = 46 Then s = ") a big fan of"
    If r = 47 Then s = "evicerate$"
    If r = 48 Then s = "borrow* "  + GenNounPhrase(0) + " from"
    If r = 49 Then s = "operate$ for centuries without true knowledge of"
    If r = 50 Then s = "hurl* " + GenNounPhrase(0) + " at"
    If r = 51 Then s = "burn*"
    If r = 52 Then s = "destroy*"
    If r = 53 Then s = "learn* the " + GenAdjective() + " truth about"
    If r = 54 Then s = "plan* an escape from"
    If r = 55 Then s = ") captured and consumed by"
   
    Dim As String vt
   
    For i As Integer = 1 To Len(s)
        Dim As String c = Mid(s, i, 1)
        Dim As String w = c
        If c = "$" Then
            If tense = 0 Then w = ""
            If tense = 1 Then w = "d"
        End If
        If c = "*" Then
            If tense = 0 Then w = ""
            If tense = 1 Then w = "ed"
        End If
        If c = ")" Then
            If tense = 0 Then w = "be"
            If tense = 1 Then w = "was"
        End If
        If c = "^" Then
            If tense = 0 Then w = "have"
            If tense = 1 Then w = "had"
        End If
        If c = "&" Then
            If tense = 0 Then w = "y"
            If tense = 1 Then w = "ies"
        End If
        vt += w
    Next
   
    If qrand(10) < 3 Then vt = GenAdverb() + " " + vt
   
    Return vt
End Function


Function GenIntransitiveVerbPhrase() As String
    Dim As Integer n = 28
    Dim As Integer r = qrand(n)
    Dim As String s
   
    Do
        r = qrand(n)
    Loop Until r <> PrevIntransitiveVerb
    PrevIntransitiveVerb = r
   
    If r = 0 Then s = "leaves"
    If r = 1 Then s = "sleeps"
    If r = 2 Then s = "obliterates"
    If r = 3 Then s = "hibernates"
    If r = 4 Then s = "breathes"
    If r = 5 Then s = "self-flagellates"
    If r = 6 Then s = "meditates"
    If r = 7 Then s = "rises from the " + GenAdjective() + " depths"
    If r = 8 Then s = "flies into a rage"
    If r = 9 Then s = "sows the seeds of its own damnation"
    If r = 10 Then s = "sweeps the floor"
    If r = 11 Then s = "feels the " + GenNoun()
    If r = 12 Then s = "returns"
    If r = 13 Then s = "rejoices"
    If r = 14 Then s = "prays"
    If r = 15 Then s = "procrastinates"
    If r = 16 Then s = "dreams"
    If r = 17 Then s = "ceases to exist"
    If r = 18 Then s = "hides"
    If r = 19 Then s = "panics"
    If r = 20 Then s = "beams with " + GenAdjective() + " power"
    If r = 21 Then s = "laughs like a man insane"
    If r = 22 Then s = "draws itself up"
    If r = 23 Then s = "awakens"
    If r = 24 Then s = "hesitates"
    If r = 25 Then s = "trembles"
    If r = 26 Then s = "ruminates"
    If r = 27 Then s = "dies"
   
    Return s
End Function


Function GenConjunction() As String
    Dim As Integer n = 4
    Dim As Integer r = qrand(n)
    Dim As String s
   
    If r = 0 Then s = "and"
    If r = 1 Then s = "or"
    If r = 2 Then s = "but"
    If r = 3 Then s = "because"
   
    Return s
End Function


Function GenRandomSentence() As String
    Dim As String stemp = GenRandomSentenceTemplate()
    Dim As String s
   
    For i As Integer = 1 To Len(stemp)
        Dim As String c = Mid(stemp, i, 1)
        Dim As String w
       
        If c = "0" Then
            w = GenNoun()
        Elseif c = "1" Then
            w = GenNounPhrase(0)
        Elseif c = "2" Then
            w = GenTransitiveVerbPhrase(1)
        Elseif c = "3" Then
            w = GenConjunction()
        Elseif c = "4" Then
            w = GenIntransitiveVerbPhrase()
        Elseif c = "5" Then
            w = GenTransitiveVerbPhrase(0)
        Elseif c = "6" Then
            w = GenAdjective()
        Elseif c = "7" Then
            w = GenAdverb()
            Else w = c
        End If
       
        s += w
    Next
   
    Return CapFirst(s)
End Function




Print "'" + CapFirst(GenNounPhrase(0)) + "'"
Print

For i As Integer = 0 To 5
    Print GenRandomSentence() + " ";
Next
Sleep
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Postby agamemnus » Mar 08, 2010 8:51

I have a system too; it's in php but I'll translate it to fb...
jevans4949
Posts: 1151
Joined: May 08, 2006 21:58
Location: Crewe, England

Postby jevans4949 » Mar 08, 2010 9:42

Other possible use: to generate spam email?
lrcvs
Posts: 576
Joined: Mar 06, 2008 19:27
Location: Spain

Postby lrcvs » Mar 08, 2010 18:04

To: Duke4e

If your program is very very very very good ...

But mine is different, has other uses more general

Greetings!!
lrcvs
Posts: 576
Joined: Mar 06, 2008 19:27
Location: Spain

Postby lrcvs » Mar 08, 2010 18:07

To: jevans4949

Do not know, probably!

But I have not created to spam, is to experiment with simply text

Greetings
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Postby agamemnus » Mar 08, 2010 18:29

:\

It's very useful for games.

Here is how my random phrase program works. I haven't implemented an FB version. (yet?) It's of middle-of-the-road complexity. Any more complex and it would require a specialized phrase building program. Less complex leaves out features!

First, I create a list of phrases or words. Each phrase has two numbers assigned to it: one is the option set number, and the other is the phrase number within the option set. For example, here are 6 option sets.

text="
[0],,
0: businessman,,
1: IT specialist,,
2: marketeer,,
3: cost specialist,,

[1],,
0: Money,,
1: Cash,,
2: Gold,,

[2],,
0: Leon,,
1: Smarty,,
2: Pen,,

[3],,
0: Gu,,
1: Fab,,
2: Spark,,

[4],,
0:stein,,
1:ovich,,
2:no,,
3:-Li,,

[5],,
0:Jack,,
1:Andy,,
2:Michael,,
3:Chris,,
4:Matt,,
5:John,,
6:Alice,,
7:Nicole,,
8:Danielle,,
9:Emily,,
10:Laura,,
11:Lin,,
"


Then, I specify the sentence structure. A number in square brackets indicates that the phrase program chooses one of the option sets above. A secondary number in parentheses indicates which phrase/word to randomly pick from the option set.

"(all)" means any word in the option set can be picked.
"(num1, num1, num3)" selects an option set phrase from the list of option set IDs.

A "," precedes another number in square brackets.

This can be nested:
(num1:x, num2:y, num3:z) signifies that the program should pick any of these paths at random to be followed.

text matches="
[5](all),
[0](
0:(
[1](all)
),
1:(
[2](all)
),
2:(
[3](all)
),
),
[4](all)
"


A few more strings:

"Text type" is normally "random 1:n match". A "random" text type signifies that the program just randomly picks one phrase from the list.

The "text replacements" string functions like.. a text replacement-- see example 2 below.

I send these four/five strings to the program, which creates an initial data structure in memory. I also assign a sentence ID to this sentence at the same time. Then call the program with the sentence ID when needed.



Here are three full examples of my system...

<text name="employee name generation" text type="random 1:n match"
text="
[0],,
0: businessman,,
1: IT specialist,,
2: marketeer,,
3: cost specialist,,

[1],,
0: Money,,
1: Cash,,
2: Gold,,

[2],,
0: Leon,,
1: Smarty,,
2: Pen,,

[3],,
0: Gu,,
1: Fab,,
2: Spark,,

[4],,
0:stein,,
1:ovich,,
2:no,,
3:-Li,,

[5],,
0:Jack,,
1:Andy,,
2:Michael,,
3:Chris,,
4:Matt,,
5:John,,
6:Alice,,
7:Nicole,,
8:Danielle,,
9:Emily,,
10:Laura,,
11:Lin,,
"

text replacements=""

text matches="
[5](all),
[0](
0:(
[1](all)
),
1:(
[2](all)
),
2:(
[3](all)
),
),
[4](all)
">


<text name="ftext past occupation" text type="random 1:n match"
text="
[0],,
0: fishing,,
1: recreational sports,,
2: media,,

[1],,
0: crab fisherman,,
1: longshoreman,,
2: boat operator,,

[2],,
0: professional angler,,
1: skydiving instructor,,
2: survival trainer,,
3: bear-wrestler,,

[3],,
0: news anchor,,
1: weatherman,,
2: nature show host,,
3: special investigator,,

[4],,
0: off the shores of,,
1: on the plains of,,
2: on the steppes of,,

[5],,
0: North Carolina,,
1: Louisiana,,
2: Alaska,,
3: American Samoa,,
4: the Serengeti,,
5: the Australian Outback,,
6: the US Great Plains,,
7: Eastern Europe,,
"

text replacements="
lotsofwater=[5](0,1,2,3)
lotsofland=[5](4,5,6,7)
"

text matches="
[0](0:(
[1](all),
[4](0:[lotsofwater]),
),
1:(
[2](all),
[4](1:[lotsofland], 2:[lotsofland]),
),
2:
(
[3](all),
[4](1:[lotsofland], 2:[lotsofland]),
),
)
">


<text name="ftext easy phrase" text type="random"
text="a piece of cake,,
easier than stealing candy from a baby,,
just gravy,,
easy as pie,,
a cake walk,,
a walk in the park">


<text name="ftext large thing" text type="random"
text="enormous,,
gigantic,,
sumo-wrestler-like,,
galactic,,
giant-like,,
McDonald's-like,,
Big-Mac-like,,
mouth-dropping">
lrcvs
Posts: 576
Joined: Mar 06, 2008 19:27
Location: Spain

Postby lrcvs » Mar 08, 2010 21:24

To: Agamemnus

Your programs are great and complex for me.

Are more developed than mine.

My program is simple and small, only serves to fill arrays, files ...

I can not compare with yours.

Yours are better than mine.

Greetings
agamemnus
Posts: 1842
Joined: Jun 02, 2005 4:48

Postby agamemnus » Mar 09, 2010 8:43

Simple programs can always have their uses...

Edit:

Allow me to expand on this. A simple program is the starting point of a complex program. A well-done complex program is just a bunch of streamlined simple programs (or let's say, functions) acting in concert!
lrcvs
Posts: 576
Joined: Mar 06, 2008 19:27
Location: Spain

Postby lrcvs » Mar 09, 2010 18:12

Thank you very much for your interest.!
rdc
Posts: 1713
Joined: May 27, 2005 17:22
Location: Texas, USA
Contact:

Postby rdc » Mar 09, 2010 20:24

duke4e wrote:This better?


It actually makes a sort of nonsense sense. :)
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york

Postby rolliebollocks » Apr 03, 2010 15:04

Hey Duke4e,

I'd like to tinker with your sentence generator and fuse it to my dialog engine, which I posted below for your perusal. It's a simple keyword->response getter, file based... Works for interactions between humans and NPC's. Peace,

rb

Dialog_Engine.bas

Code: Select all

#include once "file.bi"
#include once "rb_strings.bas"

#define MAX_KEYWORDS 10000

type KeyWord
    as string trigger
    as string response
end type

type Conversation
   
    as KeyWord keywords(MAX_KEYWORDS)
    as integer keywordcount = 0
   
    declare sub LoadDialog ( filename as string )
    declare function FindReply ( inWord as string ) as string
    declare function Listen_Reply ( inDialog as string ) as string
    declare function WordLength ( inDialog as string ) as integer
    declare function GetWord ( inDialog as string, index as integer ) as string
    declare function LoadFileAsString( byref filename as string ) as string
   
end type

function Conversation.LoadFileAsString( byref filename as string ) as string
   
dim x as string

   if( open( filename for input access read as #13 ) = 0 ) then
      close #13
      if( open( filename for binary access read as #13 ) = 0 ) then
         x = space( lof( 13 ))
         get #13,,x
         close #13
      else
         print "Unable to open '" & filename & "'"
      end if
   else
      print "File not found '" & filename & "'"
        return "0"
   end if

   function = x

end function

sub Conversation.LoadDialog ( filename as string )
   
    dim as integer f = freefile
    dim as string isinstring
   
    if fileexists ( filename ) then
       
        open filename for input as #f
           
            while not eof(f)
               
                line input #f, isinstring
   
                if isinstring[0] = _TK_NULL then goto reloop
                if isinstring[0] = _TK_COMMENT then goto reloop
                if isinstring[0] = _TK_ENDOFLINE then goto reloop
                if isinstring[0] = _TK_ENTER then goto reloop
                             
                if isinstring[0] = asc("#") then
                   
                    keywordcount += 1
                    keywords(keywordcount).trigger = right(isinstring, len(isinstring) - 1)
                   
                    do while ucase(isinstring) <> "/END"
                        line input #f, isinstring
                                               
                        select case isinstring[0]
                       
                        case asc("@")
                            keywords(keywordcount).response = this.LoadFileAsString ( right(isinstring, len(isinstring) - 1) )
                                                   
                        case asc("/")
                           
                        case asc("#")
                            Consout ("Dialog file is broken at " & isinstring)
                            Consout ("Be sure to end block with /END.")
                            Consout ("Crash now bye.")
                            sleep:end
                       
                        case else
                             keywords(keywordcount).response &= isinstring & !"\r\n\r\n"
                       
                        end select
                       
                       
                    loop
               
                 else
                   
                            Consout ("Dialog file is broken at " & isinstring)
                            Consout ("Be sure to end block with /END.")
                            Consout ("Crash now bye.")
                            sleep:end
                 
                 endif
reloop:
            wend
            close #f
                   
    else
       
        Consout ( filename & " not found.")
        sleep:end
   
    endif
       

end sub

function Conversation.Listen_Reply ( inDialog as string ) as string

    dim as string outResponse = "" 
    inDialog = RemChr ( indialog, " " )
   
        for ii as integer = 1 to keywordcount
            if isinstr (ucase(indialog), keywords(ii).trigger) = -1 then
                outResponse &= keywords(ii).response & !"\r\n\r\n"
            endif
        next
   
    if outResponse = "" then outResponse = "<NO REPLY>"
     
    return outResponse   

end function

function Conversation.WordLength ( inDialog as string ) as integer

    dim as integer wordcount
   
    inDialog &= !"\n"

    for i as integer = 0 to len(inDialog) - 1
        if inDialog[i] = _TK_NULL   _
        or inDialog[i] = _TK_CR  _
        or inDialog[i] = _TK_ENDOFLINE  _
        or inDialog[i] = _TK_DOT    _
        or inDialog[i] = _TK_COMMA  _
        or inDialog[i] = _TK_SPACE then
            wordcount += 1
        endif
    next
   
    return wordcount
   
end function

function Conversation.FindReply ( inWord as string ) as string
   
    for i as integer = 1 to keywordcount
        if inWord = keywords(i).trigger then
            return keywords(i).response
        endif
    next

    return "<NO REPLY>"

end function

function Conversation.GetWord ( inDialog as string, index as integer ) as string

    dim as integer wordcount = 0
    dim as string word
   
    if index = 0 then

        for i as integer = 0 to len(inDialog) - 1
            if inDialog[i] = _TK_NULL   _
            or inDialog[i] = _TK_CR  _
            or inDialog[i] = _TK_ENDOFLINE  _
            or inDialog[i] = _TK_DOT    _
            or inDialog[i] = _TK_COMMA  _
            or inDialog[i] = _TK_SPACE then
                return word
                exit function
            else
                word &= chr(inDialog[i])
            endif
        next
       
    endif
   
    for i as integer = 0 to len(inDialog) - 1
       
        if inDialog[i] = _TK_NULL   _
        or inDialog[i] = _TK_CR  _
        or inDialog[i] = _TK_ENDOFLINE  _
        or inDialog[i] = _TK_DOT    _
        or inDialog[i] = _TK_COMMA  _
        or inDialog[i] = _TK_SPACE then
           
            wordcount += 1
            if wordcount = index then
                for ii as integer = i+1 to len(inDialog) - 1
                    if inDialog[ii] = _TK_NULL   _
                    or inDialog[ii] = _TK_CR  _
                    or inDialog[ii] = _TK_ENDOFLINE  _
                    or inDialog[ii] = _TK_DOT    _
                    or inDialog[ii] = _TK_COMMA  _
                    or inDialog[ii] = _TK_SPACE then
                        return word
                    else
                        word &= chr(inDialog[ii])
                    endif
                next
            endif
           
        endif
    next
   
                   
end function

'
dim as Conversation inconv

inconv.LoadDialog "PLAYER.dialog"
? inconv.listen_reply ( "is nappy happy" )
? inconv.listen_reply ( "hello" )

sleep


PLAYER.dialog

Code: Select all

#HELLO
fa LA
/end
#NAPPY
nappy as all hell
/end


rb_strings.bas

Code: Select all

#include once "file.bi"
#include once "fbgfx.bi"
'///////////////////////////////////////////////////////////////////////////////
'                  Contact: dtolkacz@gmail.com  RolliBollocks2009
'///////////////////////////////////////////////////////////////////////////////
Declare Function isDelimiter ( inchr As Ubyte ) As Integer
Declare Function isPunctuation ( inchr As Ubyte ) As Integer
Declare Function isInStr ( strbig As Const String, strlittle As Const String ) As Integer
Declare Function IsInStr_BCM (Byref strbig As String,Byref strlittle As String, BADCHARMAX As Integer = 0 ) As Uinteger
Declare Function IsInStr_Naive ( strbig As String, strlittle As String ) As Integer
Declare Function isInStr_FZZY ( Byref strlittle As Const String, Byref strbig As Const String, fzzy As Single = 0 ) As Uinteger
Declare Function IsInStr_OCC (Byref strbig As String,Byref strlittle As String, BADCHARMAX As Integer ) As Uinteger
Declare Function isInStr_WORDIDX ( Byref strbig As String,Byref strlittle As String ) As Uinteger
Declare Function Reverse ( instring As String ) As String
Declare Function RemChr ( instring as string, remasc as string ) as string
Declare Function RemWord ( indialog as string, byeword as string ) as string
Declare Function RemWordIdx ( indialog as string, index as integer ) as string
Declare Function GetWord ( inDialog As String, index As Integer ) As String
Declare Function PutWord ( indialog As String, index As Integer, newword As String ) As String
Declare Function ParamSwap ( Byref instring As String, element As Integer,  newparam As String ) As String
Declare Function CutLeftFrom_Char ( instring As String, idx As Integer ) As String
Declare Function CutRightFrom_Char ( instring As String, idx As Integer ) As String
Declare Function CutRightFrom ( instring As String, wordindexbgn As Uinteger ) As String
Declare Function CutLeftFrom ( instring As String, wordindexend As Uinteger ) As String
Declare Function CAR ( indialog As String ) As String
Declare Function CDR ( indialog As String ) As String
Declare Function StrReplace ( instring As String, old As String, newstr As String ) As String
Declare Function scramble ( instring As String ) As String
Declare Function WordCounter ( inDialog As String ) As Integer
Declare Function GetCount ( inDialog As String, delim As Ubyte ) As Integer
Declare Function ArrayToLine ( inarray() As String ) As String
Declare Function GetLineCount ( filename As String ) As Integer
Declare Function LoadFileAsString( Byref filename As String ) As String
Declare Function Zleft ( s1 As Zstring Ptr, idx As Integer ) As String
Declare Function Zright ( s1 As Zstring Ptr, idx As Integer ) As String
Declare Function zAsc ( s1 As Zstring Ptr, idx As Integer ) As Ubyte
Declare Function zChr ( s1 As Zstring Ptr, idx As Integer ) As String
Declare Function zstrTOstr ( s1 As Zstring Ptr ) As String
Declare Function strTOzstr ( Byval s1 As String ) As Zstring Ptr 
Declare Function zstrIndexReturn ( s1 As Zstring Ptr, v1 As Uinteger, v2 As Uinteger ) As String
Declare Sub Print_Center ( instring As String, box_x As Single , box_y As Single, c As Integer )
Declare Sub Make_Box ( inChr As String, box_x1 As Single, box_x2 As Single, box_y1 As Single, box_y2 As Single, c As Integer )
Declare Function Stagger ( instring As String ) As String
'///////////////////////////////////////////////////////////////////////////////
enum TOKENS
    _TK_NULL        = Asc("")
    _TK_TAB         = 9
    _TK_CR          = 13
    _TK_ENDOFLINE   = Asc(!"\n")
    _TK_ENTER       = Asc(!"\r")
    _TK_SPACE       = Asc(" ")
    _TK_AMPERSAND   = Asc("&")
    _TK_COMMA       = Asc(",")
    _TK_STRING      = Asc("$")
    _TK_INTEGER     = Asc("%")
    _TK_PERCENT     = Asc("%")
    _TK_AT          = Asc("@")
    _TK_POUND       = Asc("#")
    _TK_DOT         = Asc(".")
    _TK_RPAREN      = Asc(")")
    _TK_LPAREN      = Asc("(")   
    _TK_PLUS        = Asc("+")
    _TK_MINUS       = Asc("-")
    _TK_ASTERISK    = Asc("*")
    _TK_MULT        = Asc("*")
    _TK_DIVIDE      = Asc("/")
    _TK_FSLASH      = Asc("/")
    _TK_BSLASH      = Asc("\")
    _TK_UNDERSCORE  = Asc("_")
    _TK_LBRACKET    = Asc("[")
    _TK_RBRACKET    = Asc("]")
    _TK_EQUAL       = Asc("=")
    _TK_COMMENT     = Asc("'")
    _TK_APOSTROPHE  = Asc("'")
    _TK_LSET        = Asc("{")
    _TK_RSET        = Asc("}")
    _TK_PIPE        = Asc("|")
    _TK_GREATERTHAN = Asc(">")
    _TK_LESSTHAN    = Asc("<")
    _TK_DBLQUOTE    = Asc($"")
    _TK_QUESTION    = Asc("?")
    _TK_EXCLAIM     = Asc("!")
    _TK_COLON       = Asc(":")
End enum
'-------------------------------------------------------------------------------
' Checks for the listed elements at a given point in any string, and returns -1
' for true, 0 for false
'-------------------------------------------------------------------------------
Function isDelimiter ( inchr As Ubyte ) As Integer
    If inchr = _TK_ENDOFLINE _
    Or inchr = _TK_TAB _
    Or inchr = _TK_NULL _
    Or inchr = _TK_CR _
    Or inchr = _TK_SPACE Then
        Return -1
    Else
        Return 0
    Endif
End Function
'? isDelimiter(32)
'? isDelimiter(78):sleep
'-------------------------------------------------------------------------------
' Checks for the listed elements at a given point in any string, and returns -1
' for true, 0 for false
'-------------------------------------------------------------------------------
Function isPunctuation ( inchr As Ubyte ) As Integer
    If inchr = _TK_ENDOFLINE _
    Or inchr = _TK_SPACE _
    Or inchr = _TK_DOT _
    Or inchr = _TK_RPAREN _
    Or inchr = _TK_LPAREN _
    Or inchr = _TK_APOSTROPHE _
    Or inchr = _TK_AMPERSAND _
    Or inchr = _TK_TAB _
    Or inchr = _TK_NULL _
    Or inchr = _TK_CR _
    Or inchr = _TK_QUESTION _
    Or inchr = _TK_EXCLAIM _
    Or inchr = _TK_COLON Then
        Return -1
    Else
        Return 0
    Endif
End Function
'-------------------------------------------------------------------------------
'Searches strbig for strlittle, and returns position (fastest)
'-------------------------------------------------------------------------------
Function isInStr ( strbig As Const String, strlittle As Const String ) As Integer
     Dim As Uinteger ll=Len(strlittle)-1, lb = Len(strbig) - 1, i=0,ii=0, position=0
     If strbig = strlittle Then Return 1
    For i   = 0 To lb
        If strbig[i] = strlittle[0] Then
            If strbig[i+ll] = strlittle[ll] Then
                If i+ll <= lb Then
                    position=i+1
                    For ii   = (i) To i + ( ll / 2 )
                        If strbig[ i+ll - ( ii-i ) ] <> strlittle [ll-(ii-i)] _
                        Or strbig[ii] <> strlittle[ ii - i ] Then
                            position=0:Exit For
                        Endif
                    Next ii
                    i+=ll
                Endif
            Endif
        Endif
                If position Then Return position
            Next i
                Return 0
End Function
'? isInStr ("dhfjkshlfjkdhsfjkhdsjkhfdjkshfjkldshjkfhdskjlhfdkjlshfjkdshlfds", "jkhdsjkhfdjkshfjkldshjkfhdskjlhfdkjlshfjkdshlf" ):sleep
'-------------------------------------------------------------------------------
'Searches strbig for strlittle
'-------------------------------------------------------------------------------
Function IsInStr_Naive ( strbig As String, strlittle As String ) As Integer
   
    Dim As Integer ll = Len(strlittle)-1, lb = Len(strbig)-1
    Dim As Integer OK = 0
    For i As Integer = 0 To lb
        If strbig[i] = strlittle[0] Then
            If strbig[i+ll] = strlittle[ll] Then
                OK = i+1
                For ii As Integer = i To i+ll
                    If strbig[ii] <> strlittle[ ii - i ] Then OK = 0:Exit For
                Next
            Else
                i+=ll
            Endif
        Endif
        If OK Then Return OK
    Next
   
    Return OK
   
End Function
'-------------------------------------------------------------------------------
'Searches strbig for strlittle, allows for a bad character max which will return
'a false result as true if enough of the characters are similar
'-------------------------------------------------------------------------------
Function IsInStr_BCM (Byref strbig As String,Byref strlittle As String, BADCHARMAX As Integer = 0 ) As Uinteger
    Dim As Uinteger position, bcm
     Dim ll As Uinteger=Len(strlittle)-1
     Dim lb As Uinteger=Len(strbig) - 1
     Dim As Uinteger i,ii     
     If strbig = strlittle Then Return 1
    For i   = 0 To lb
        If strbig[i] = strlittle[0] Then
            If strbig[i+ll] = strlittle[ll] Then
                If i+ll <= lb Then
                    position=i+1
                    For ii   = (i) To i + ( ll Shr 1 )
                        If strbig[ i+ll - ( ii-i ) ] <> strlittle [ll-(ii-i)] _
                        Or strbig[ii] <> strlittle[ ii - i ] Then
                            bcm+=1
                            If bcm > BADCHARMAX Then
                                position=0
                                Exit For
                            Endif
                        Endif                       
                    Next ii
                    bcm = 0
                    i+=ll
                Endif
            Endif
        Endif
                If position Then Return position
            Next i
                Return 0
End Function
'-------------------------------------------------------------------------------
'Searches strbig for strlittle, wherein strlittle is a whole word separated by a
'space, and it returns its position in reference to other whole words
'-------------------------------------------------------------------------------
Function isInStr_WORDIDX ( Byref strbig As String,Byref strlittle As String ) As Uinteger
   
    Dim As Integer i
   
    For i = 0 To GetCount ( strbig, _TK_SPACE )
        If GetWord ( strbig, i ) = strlittle Then Return i+1
    Next
   
    Return 0
   
End Function
'-------------------------------------------------------------------------------
'searches strbig for strlittle and returns how many times the word occurs in the
'strbig string
'-------------------------------------------------------------------------------
Function IsInStr_OCC (Byref strbig As String,Byref strlittle As String, BADCHARMAX As Integer ) As Uinteger
    Dim As Uinteger position, bcm, occ
     Dim ll As Uinteger=Len(strlittle)-1
     Dim lb As Uinteger=Len(strbig) - 1
     Dim As Uinteger i,ii
     
     If strbig = strlittle Then Return 1
     
    For i   = 0 To lb
        If strbig[i] = strlittle[0] Then
            If strbig[i+ll] = strlittle[ll] Then
                If i+ll <= lb Then
                    position=i+1
                    For ii   = (i) To i + ( ll Shr 1 )
                        If strbig[ i+ll - ( ii-i ) ] <> strlittle [ll-(ii-i)] _
                        Or strbig[ii] <> strlittle[ ii - i ] Then
                            bcm+=1
                            If bcm > BADCHARMAX Then
                                position=0
                                Exit For
                            Endif
                        Endif                       
                    Next ii
                    bcm = 0
                    i+=ll
                Endif
            Endif
        Endif
                If position Then occ+=1:position = 0
            Next i
                Return occ
End Function
'-------------------------------------------------------------------------------
'searches for the occurence of a word backward in a string, returns position
'-------------------------------------------------------------------------------
Function IsInStrRev ( strbig As String, strlittle As String ) As Uinteger
   
    strlittle = Reverse ( strlittle )
    Function = isinstr ( strbig, strlittle )
   
End Function
'-------------------------------------------------------------------------------
'returns the string written backward
'-------------------------------------------------------------------------------
Function Reverse ( instring As String ) As String
   
    Dim outstring As String = instring
    Dim As Integer l = Len(instring) - 1
   
    For i As Integer = 0 To l
        outstring[ l - i ] = instring[i]
    Next

    Return outstring

End Function
'-------------------------------------------------------------------------------
'returns the string minus the character specified by remasc
'-------------------------------------------------------------------------------
Function RemChr ( instring as string, remasc as string ) as string
    Dim As String outstring = ""
    For i As Integer = 0 To Len(instring) - 1
        If instring[i] <> Remasc[0] then outstring &= chr(instring[i])
    Next
    Return outstring
End Function
'-------------------------------------------------------------------------------
'returns the string minus the word specified by byeword
'-------------------------------------------------------------------------------
Function RemWord ( indialog as string, byeword as string ) as string

    Dim As String outstring = ""
    Dim As String text = indialog
   
    For i As Integer = 0 To WordCounter ( text ) - 1
        If GetWord ( text, i ) <> byeword Then
            outstring &= GetWord ( text, i ) & " "
        Endif
    Next
   
    Return outstring

End Function
'-------------------------------------------------------------------------------
'returns the string minus the word's index (position in string) specified by index
'-------------------------------------------------------------------------------
Function RemWordIdx ( indialog as string, index as integer ) as string

    Dim As String outstring = ""
   
    For i As Integer = 0 To WordCounter (indialog)
        If i <> index Then
            outstring &= GetWord ( indialog, i ) & " "
        Endif
    Next
   
    Return outstring

End Function
'-------------------------------------------------------------------------------
'gets a specified word in accord with specified index
'-------------------------------------------------------------------------------
Function GetWord ( inDialog As String, index As Integer ) As String

    Dim As Integer wordcount = 0
    Dim As String word = ""
   
    indialog &= Chr(32)
   
    If index = 0 Then
        For i As Integer = 0 To Len(inDialog) - 1
            If isDelimiter ( inDialog[i] ) Then
                Return word
                Exit Function
            Else
                word &= Chr(inDialog[i])
            Endif
        Next
       
    Endif
   
    For i As Integer = 0 To Len(inDialog) - 1
        If isDelimiter ( inDialog[i] ) Then
            wordcount += 1
            If wordcount = index Then
                For ii As Integer = i+1 To Len(inDialog) - 1
                    If isDelimiter ( inDialog[ii] ) Then
                        word = RemChr (word," ")
                        Return word
                    Else
                        word &= Chr(inDialog[ii])
                    Endif
                Next
            Endif
        Endif
    Next
   
    Return ""
                   
End Function
'-------------------------------------------------------------------------------
'inserts a word at specified index
'-------------------------------------------------------------------------------
Function PutWord ( indialog As String, index As Integer, newword As String ) As String
   
    Dim As Integer wordcount = 0
    Dim As String edit1 = indialog
    Dim As String edit2 = indialog
   
    If index = 0 Then
        edit1 = newword & " " & edit1
        Return edit1
    Endif
   
        For i As Integer = 0 To Len(inDialog) - 1
            If isDelimiter ( inDialog[i] ) Then
                wordcount += 1
                If wordcount = index Then
                    edit1 = zstrindexreturn ( strtozstr(indialog), 0, i )
                    edit2 = zstrindexreturn ( strtozstr(indialog), i+1, Len(indialog)-1 )
                    edit1 &= " " & newword & " " & edit2
                    Return edit1
                Endif
            Endif
        Next
   
End Function
'-------------------------------------------------------------------------------
'swaps a word with new word at specified index (element)
'-------------------------------------------------------------------------------
Function ParamSwap ( Byref instring As String, element As Integer,  newparam As String ) As String

    instring = RemWordIdx ( instring, element )
    instring = PutWord ( instring, element, newparam )   
   
    Return instring

End Function
'-------------------------------------------------------------------------------
'returns a new string with old string's characters all shuffled up (requires
'randomize to be initialized)
'-------------------------------------------------------------------------------
Function scramble ( instring As String ) As String
   
    Dim As String outstring = Space(Len(instring))
    Dim As Integer i = 0, r = 0, l = Len(instring) - 1
   
    Do While isinstr ( outstring, " " )
        r = Rnd * l
        If outstring[r] = 32 Then
            outstring[r] = instring[i]
            i+=1
        Endif
    Loop
   
    Return outstring
   
End Function
'-------------------------------------------------------------------------------
'searches instring for old and replaces it with newstr
'-------------------------------------------------------------------------------
Function StrReplace ( instring As String, old As String, newstr As String ) As String
   
    Dim As Integer spot = 0
    Dim As String outstring = ""
   
    For i As Integer = 1 To isinstr_OCC ( instring, old, 0 )
   
        spot = isinstr_naive ( instring, old ) - 1
        outstring &= cutleftfrom_char ( instring, spot ) & newstr
        instring = cutrightfrom_char ( instring, spot+Len(old) )
        spot += Len(old)
       
    Next
   
    Return outstring & instring
       
End Function
'-------------------------------------------------------------------------------
'returns all the characters left of index idx
'-------------------------------------------------------------------------------
Function CutLeftFrom_Char ( instring As String, idx As Integer ) As String
   
    Dim As String outstring
   
    For i As Integer = 0 To idx - 1
        outstring &= Chr(instring[i])
    Next
   
    Return outstring
   
End Function
'-------------------------------------------------------------------------------
'returns all the characters right of index idx
'-------------------------------------------------------------------------------
Function CutRightFrom_Char ( instring As String, idx As Integer ) As String
   
    Dim As String outstring
   
    For i As Integer = idx To Len(instring)-1
        outstring &= Chr(instring[i])
    Next
   
    Return outstring
   
End Function
'-------------------------------------------------------------------------------
'returns all words left of word index wordindexbgn
'-------------------------------------------------------------------------------
Function CutRightFrom ( instring As String, wordindexbgn As Uinteger ) As String
   
    Dim As String outstring = ""
   
    For i As Integer = wordindexbgn - 1 To WordCounter( instring )
        outstring &= GetWord( instring, i ) & Chr(32)
    Next
   
    Function = outstring
   
End Function
'-------------------------------------------------------------------------------
'returns all words right of word index wordindexbgn
'-------------------------------------------------------------------------------
Function CutLeftFrom ( instring As String, wordindexend As Uinteger ) As String
   
    Dim As String outstring = ""
   
    For i As Integer = 0 To wordindexend - 1
        outstring &= GetWord( instring, i ) & Chr(32)
    Next
   
    Function = outstring
   
End Function
'-------------------------------------------------------------------------------
'returns first element in a string list
'-------------------------------------------------------------------------------
Function CAR ( indialog As String ) As String
    Return GetWord ( indialog, 0)
End Function
'-------------------------------------------------------------------------------
'returns all elements except the first element in a string list
'-------------------------------------------------------------------------------
Function CDR ( indialog As String ) As String
    Return RemWordIdx ( indialog, 0)
End Function
'-------------------------------------------------------------------------------
'counts words in a string
'-------------------------------------------------------------------------------
Function WordCounter ( inDialog As String ) As Integer
    Dim As Integer wordcount
    indialog &= !"\n"
    For i As Integer = 0 To Len(inDialog) - 1
        If isPunctuation ( indialog[i] ) Then
            If Not isPunctuation ( indialog[i-1] ) Then
                wordcount += 1
            Endif
        Endif
    Next
    Return wordcount
   
End Function
'-------------------------------------------------------------------------------
'counts words in a string by specified delimeter
'-------------------------------------------------------------------------------
Function GetCount ( inDialog As String, delim As Ubyte ) As Integer
    Dim As Integer wordcount
    indialog &= !"\n"
    For i As Integer = 0 To Len(inDialog) - 1
        If indialog[i] = delim Then
            wordcount += 1
        Endif
    Next
    Return wordcount
End Function
'-------------------------------------------------------------------------------
'Makes an array of words from any given sentence
'-------------------------------------------------------------------------------
#Macro Str_LineToArray ( instring, varname )
    Dim As Integer wc##varname = GetCount ( instring, _TK_SPACE )
    Redim As String varname ( wc##varname )
    For i As Integer = 0 To wc##varname
        If GetWord ( instring, i) <> "" Then varname(i) = GetWord ( instring, i)
    Next
#endmacro
'-------------------------------------------------------------------------------
'Makes an array of strings into a single string
'-------------------------------------------------------------------------------
Function ArrayToLine ( inarray() As String ) As String
    Dim As String outstring = ""
   
    For i As Integer = 0 To Ubound(inarray)
        If inarray(i) <> "" Then
            outstring &= inarray(i) & " "
        Endif
    Next
   
    Return outstring
End Function   
'-------------------------------------------------------------------------------
'Makes a multiline string into an array of lines
#macro Str_ToLineArray ( inscript, varname )
    Dim As Integer varname##linecount = GetCount(inscript, _TK_ENDOFLINE)
    Dim As String varname##newline
    Dim As String varname(varname##linecount)
    inscript &= !"\n"
    varname##linecount = 0   
    For i As Integer = 0 To Len(inscript)
        If inscript[i]  <> _TK_ENDOFLINE _
        And inscript[i] <> _TK_TAB _
        And inscript[i] <> _TK_CR _
        And inscript[i] <> _TK_NULL _
        And inscript[i] <> _TK_COLON Then
            varname##newline &= Chr(inscript[i])
        Else
            varname(varname##linecount) = varname##newline
            varname##newline = "":varname##linecount += 1
        Endif
        If varname##linecount >= Ubound(varname) Then Exit For
    Next 
#endmacro
'-------------------------------------------------------------------------------
'///////////////////////////File Stuff//////////////////////////////////////////
'Returns the amount of lines in a file
'-------------------------------------------------------------------------------
Function GetLineCount ( filename As String ) As Integer
  Dim As Integer f = Freefile
  Dim As Integer count = 0
  Dim As String nil
 
  If fileexists(filename) Then
      Open filename For Input As #f
         While Not Eof(f)
             Line Input #f, nil
             count += 1
         Wend
  Else
      count = -1
  Endif
  Close #f
  Return count
End Function
'-------------------------------------------------------------------------------
'takes a file and loads into an array line by line
'-------------------------------------------------------------------------------
#Macro File_ToLineArray ( filename, varname )
    Dim As String inscript = LoadFileAsString ( filename )
    inscript = RemChr ( inscript, chr(_TK_CR) )
    Str_ToLineArray ( inscript, varname )
#endmacro   
'-------------------------------------------------------------------------------
'loads a file into a string
'Borrowed from Jeff Marshall
'-------------------------------------------------------------------------------
Function LoadFileAsString( Byref filename As String ) As String

        Dim x As String

        If( Open( filename For Input Access Read As #13 ) = 0 ) Then
                Close #13
                If( Open( filename For Binary Access Read As #13 ) = 0 ) Then
                        x = Space( Lof( 13 ))
                        Get #13,,x
                        Close #13
                Else
                        'print "Unable to open '" & filename & "'"
                End If
        Else
        'print "File not found '" & filename & "'"
        End If

        Function = x

End Function
'-------------------------------------------------------------------------------
'returns all characters between index v1, and v2
'-------------------------------------------------------------------------------
Function StrIndexReturn ( Byval text As String, v1 As Uinteger, v2 As Uinteger ) As String
    If v1 = v2 Then Return Chr(text[v1])
    If v1>v2 Then
        Dim As String result = ""
        For i As Integer = v2 To v1
            result &= Chr(text[i])
        Next
        Return result
    Endif
    If v1<v2 Then
        Dim As String result = ""
        For i As Integer = v2 To v1
            result &= Chr(text[i])
        Next
        Return result
    Endif
    Return ""   
End Function
'-------------------------------------------------------------------------------
'///////////////////////////Zstrings to strings functions///////////////////////
'Inspirational Quote:
'The end of the string is marked by a character 0 ASCII, this is automatically managed by
'the FreeBASIC string handling functions. A character 0 ASCII must never enter in the text
'of a Zstring or it will be truncated, as no descriptor exists. -FBWiki
Function Zleft ( s1 As Zstring Ptr, idx As Integer ) As String
    Dim As String res = ""
    Dim As Zstring Ptr temp = s1
    temp[idx] = 0
    res = zstrTOstr ( temp )
    Return res   
End Function
'-------------------------------------------------------------------------------
Function zRight ( s1 As Zstring Ptr, idx As Integer ) As String
    Return zstrTOstr (s1[idx])
End Function
'-------------------------------------------------------------------------------
Function zAsc ( s1 As Zstring Ptr, idx As Integer ) As Ubyte
    Return Asc ( zleft ( zright ( s1, idx-1 ), 1 ) )
End Function
'-------------------------------------------------------------------------------
Function zChr ( s1 As Zstring Ptr, idx As Integer ) As String
    Return zleft ( zright ( s1, idx-1 ), 1 )
End Function
'-------------------------------------------------------------------------------
Function strTOzstr ( Byval s1 As String ) As Zstring Ptr   
    Return cast ( Zstring Ptr, @s1 )
End Function
'-------------------------------------------------------------------------------
Function zstrTOstr ( s1 As Zstring Ptr ) As String
    Return s1[0]
End Function
'-------------------------------------------------------------------------------
Function zstrIndexReturn ( s1 As Zstring Ptr, v1 As Uinteger, v2 As Uinteger ) As String
    If v2 <= Len(*s1) Then
        Dim As String ret = zstrTOstr ( zleft ( zright ( s1, v1), v2 ) )
        Return ret
    Else
        Return ""
    Endif
End Function
 
'----------------------------Bonus Functions------------------------------------

Function round ( inint As Single ) As Integer
   
    Dim As Single outint = inint - Int(inint)
   
    If outint >= .5 Then
        outint = Int(inint + 1)
    Else
        outint = Int(inint)
    Endif
   
    Return outint
   
End Function
'-------------------------------------------------------------------------------
' splits a string in half
'-------------------------------------------------------------------------------
#macro Zenoctomy ( instring, varname )
    Dim As String varname(2)
    varname(0) = instring
    If Len(varname(0)) = 1 _
    Or Len(varname(0)) = 0 Then
        'Pick nose
    Else
        Dim As Integer varname##length = Len(varname(0))
        'Find Middle
        Dim As Single varname##middle =  ( varname##length / 2 ) ' or divide by 2^N
        'Odd or Even?
        If varname##middle = Int(varname##middle) Then
            varname(0) = zleft(varname(0), varname##middle )
            varname(2) = zright(instring, varname##middle )
        Else
            varname(1) =  zChr(varname(0), Round( varname##middle ) )
            varname(0) = zleft(varname(0), Round( varname##middle ) -1 )
            varname(2) = zright(instring, Round (varname##middle) )
        Endif
    Endif
#endmacro
'-----------------------------Cosmetic Routines---------------------------------
'center text according to the diagonal opposite 0,0
'-------------------------------------------------------------------------------
Sub Print_Center ( instring As String, box_x As Single , box_y As Single, c As Integer )

    Draw String ( box_x Shr 1 - ( Len(instring) Shr 1)*8, box_y Shr 1), instring, c

End Sub
'-------------------------------------------------------------------------------
Sub Make_Box ( inChr As String, box_x1 As Single, box_x2 As Single, box_y1 As Single, box_y2 As Single, c As Integer )
   
    Dim As Integer widstr = (box_x2 - box_x1) / 8
    Dim As Integer lenstr = (box_y2 - box_y1) / 8
   
    For i As Integer = box_x1 To box_x2 Step 8
        Draw String ( i, box_y1 ), inChr, c
    Next
   
    For i As Integer = box_x1 To box_x2 Step 8
        Draw String ( i, box_y2), inChr, c
    Next

    For i As Integer = box_y1 To box_y2 Step 8
        Draw String ( box_x1, i ), inChr, c
    Next
   
    For i As Integer = box_y1 To box_y2 Step 8
        Draw String ( box_x2, i ), inChr, c
    Next

End Sub
'-------------------------------------------------------------------------------
'Turns every other character upper/lower/upper/lower
'-------------------------------------------------------------------------------
Function Stagger ( instring As String ) As String

    For i As Integer = 0 To Len(instring) Step 2
        If Chr(instring[i]) = Lcase(Chr(instring[i])) Then
            instring[i] -= 32
        Elseif Chr(instring[i]) = Ucase(Chr(instring[i])) Then
            instring[i] += 32
        Endif
    Next

    Return instring
End Function

'-----------------------------Console Functions---------------------------------
'print and get input from the console while in graphics mode
'-------------------------------------------------------------------------------
Sub ConsOut ( Byref Msg As String )
    Open cons For Output As #99: Print #99, Msg;: Close #99
End Sub
'-------------------------------------------------------------------------------
Function ConsIn () As String
    Dim As String msg
    Open cons For Input As #99:Line Input #99, Msg:Close #99
    Function = msg
End Function
'-------------------------------------------------------------------------------
 
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Postby duke4e » Apr 03, 2010 17:11

Well, it's not my sentence generator, I've just translated it from javascript, but feel free to do with it whatever you like.

Return to “Projects”

Who is online

Users browsing this forum: No registered users and 4 guests