'WEASLE2b.BAS Copyright Ian Musgrave 1997, QB4.x, QBASIC 1.1, PDS 7.X"
'Program to use selection to generate a given string from nonsense
'Inspired by the Richard Dawkins program and the weasle program posted
'by Wesley Elseberry. The only things you can select are the target
'string and the number of offspring. One string is selected to
'"Breed" from out of the offspring. The string is
'duplicated with one random mutation per new string.
'
'Please feel free to improve this

DEFINT A-Z

DECLARE SUB Wait10 ()
DECLARE SUB Pause ()
DECLARE SUB CheckFit ()

COMMON SHARED Target$, TargLen, Diff, BestDiff, BestFit, OffSpring

'Initalize variables
Target$ = "methinks it is a weasle"
TargLen = LEN(Target$)
OffSpring = 10

DIM SHARED CharVals(1 TO TargLen)
DIM SHARED TestVals(1 TO TargLen)
DIM SHARED TestDiff(1 TO OffSpring)
DIM SHARED Test$(1 TO OffSpring)

RANDOMIZE TIMER

Menu:
CLS
PRINT "Program to use selection to generate a given string from nonsense"
PRINT "Inspired by the Richard Dawkins program and the weasle program posted"
PRINT "by Wesley Elseberry. The only things you can select are the target"
PRINT "string and the number of offspring. One string is selected to"
PRINT CHR$(34); "Breed"; CHR$(34); "from out of the offspring. The string is"
PRINT "duplicated with one random mutation per new string."
PRINT ""
PRINT "Current string is: "; Target$
PRINT "Current Offsprint number: "; OffSpring; " (max 100)"
PRINT ""
PRINT "1) Change target string"
PRINT "2) Change Offspring Number"
PRINT "3) Proceed with simulation"
PRINT ""

DO
Key$ = INKEY$
IF LEN(Key$) THEN
        KeyVal = ASC(Key$)
ELSE
        KeyVal = 0
END IF

SELECT CASE KeyVal
CASE 49
PRINT "Type new string, lowercase letters only, 40 characters maximum: "
INPUT ; NewString$
IF NewString$ = "" THEN
        PRINT "String empty, press any key to redo"
        Pause
        GOTO Menu
END IF
IF LEN(NewString$) > 40 THEN
        Target$ = MID$(NewString$, 1, 40)
ELSE
        Target$ = NewString$
END IF
Target$ = LCASE$(Target$)
TargLen = LEN(Target$)
GOTO Menu

CASE 50
INPUT "Type new offspring number, 100 maximum: ", NewNum
IF NewNum = 0 THEN PRINT "No offspring, redo": Pause: GOTO Menu
IF NewNum > 100 THEN
        NewNum = 100
ELSE
        OffSpring = NewNum
END IF
GOTO Menu
END SELECT

LOOP UNTIL KeyVal = 51

REDIM SHARED CharVals(1 TO TargLen)
REDIM SHARED TestVals(1 TO TargLen)
REDIM SHARED TestDiff(1 TO OffSpring)
REDIM SHARED Test$(1 TO OffSpring)

'Set up array of character values so we can test for
'differences from the target string
FOR J = 1 TO TargLen
CharVals(J) = ASC(MID$(Target$, J, 1))
NEXT

'Make First generation of random strings
FOR I = 1 TO OffSpring
    DO UNTIL LEN(Test$(I)) = TargLen
    Char$ = CHR$((INT(RND * 26) + 96))
    IF Char$ = CHR$(96) THEN Char$ = CHR$(32)
    Test$(I) = Test$(I) + Char$
    LOOP
NEXT

'Initalise variables to test characters.
MaxDiff = 90 * TargLen
BestDiff = MaxDiff
CurrBestDiff = MaxDiff
BestFit = 0

OutFile$ = "E:\wout.txt"
OPEN OutFile$ FOR OUTPUT AS #1

'Pick closest string of the first generation, and breed from that
CALL CheckFit

Start:
CLS
LOCATE 5, 2: PRINT "Target:"; TAB(12); Target$; "  Diff"; BestDiff; "    Generation: "; Gen
LOCATE 7, 2: PRINT "Current Best String is   "; Test$(BestFit); " with a difference of "; BestDiff
LOCATE 8, 2: PRINT "Previous Best String was "; Parent$; " with a difference of "; CurrBestDiff

Wait10
Gen = Gen + 1
'Find the closest (ie fittest) string
'Note, there is NO locking

                CurrBestDiff = BestDiff
                Parent$ = Test$(BestFit)



'Create Offspring, all offspring are mutants
'no site is preserved, contrary to claims bt Dembski
FOR I = 1 TO OffSpring
             Site = (RND * TargLen) + 1
             IF Site > TargLen THEN Site = TargLen
             Char$ = CHR$((INT(RND * 26) + 96))
             IF Char$ = CHR$(96) THEN Char$ = CHR$(32)
             Test$(I) = Parent$
             MID$(Test$(I), Site) = Char$
NEXT

'test Offsprings fitness
CALL CheckFit

'If string matches, halt, otherwise select best string and breed from that
IF BestDiff = 0 THEN
 LOCATE 5, 2: PRINT "Target:"; TAB(12); Target$; "  Diff"; BestDiff; "    Generation: "; Gen
 LOCATE 7, 2: PRINT "Current Best String is   "; Test$(BestFit); " with a difference of "; BestDiff
 LOCATE 8, 2: PRINT "Previous Best String was "; Parent$; " with a difference of "; CurrBestDiff
 PRINT #1, Test$(BestFit); " ;"; Gen
 CLOSE
 END
END IF
PRINT #1, Test$(BestFit); " ;"; Gen ; " ;"; BestDiff

GOTO Start

SUB CheckFit

'Check for the best fit. The ASCII values for each
'character of the test string are subtracted from
'each corresponding character in the target string
'as the fit gets better the values converge to 0.
'this is probably a suboptimal way to do it.

BestDiff = 4000
FOR I = 1 TO OffSpring    'for each offspring
Diff = 0
    FOR J = 1 TO TargLen
    TestVals(J) = ASC(MID$(Test$(I), J, 1))
    Diff = Diff + (ABS(CharVals(J) - TestVals(J)))
    NEXT
    TestDiff(I) = Diff
    IF Diff < BestDiff THEN   'Find the best fit of this iteration
       BestDiff = Diff
       BestFit = I            'Keep string index
    END IF
NEXT

END SUB

SUB Pause

DO
LOOP UNTIL LEN(INKEY$)

END SUB

SUB Wait10
'pauses for 0.05 seconds
Start# = TIMER
DO
Now# = TIMER
Count# = (Now# - Start#)
LOOP UNTIL Count# > .05
END SUB