-------------------------------------------------
--GA-Math.ex Version 1.2 Quark 9/05
--Uses a population of GA beings to evolve a formula that yields the correct
--answers to the given inputs.  A "being" is a sequence containing a personal
--register, a series of "genes", private numbers, and other compontents.
--Uses REGLEN register locs. The beings have only the ability 
--to apply basic math operations to their register contents. After a
--series of ANSLEN trys, the population is halved and that part is then
--regenerated from the genes of the best half.
--A maximum of three variables is allowed to be entered in the user formula.
--Each being has three private numbers from which one is supplied for each
--variable in the formula.  Private numbers do not change during a being's life.
--Example problem: given c=3.14159*r+r, then the input for each try would be
-- a random value for r. The responses of the beings is compared with the
-- answer (the Circumference). The beings are assessed by their closeness
--to the answer.
--Changes: many small ones.  The flickering screen report is gone.  There are
--now three private numbers for each being. For each formula variable there is
--now a private number.  Added frc and nop operations.
--Compressed to one file by IncAll.ex and Mash.ex
-------------------------------------------------
include eval.e --D.Cuny's eval lib
with trace
--users can vary some of the items below to affect prg behavior
constant OPS={
{"abs",1},
{"rec",1},
{"chg",1},
{"add",2},
{"sub",2},
{"mul",2},
{"div",2},
{"int",1},
{"rem",2},
{"frc",1},
{"nop",0}
}
--abs=absolute, rec=reciprocal, chg=change-sign, int=floor, 
--rem=remainder, frc=decimal fraction, nop=no operation
--nop should always be last
constant OPNUM=length(OPS)--number of math operations available to the beings
constant POPNUM=400--the size of the population
constant MINGENES=6--minimum number of genes per being
constant RPAT={0,0,0,0,0,0,0}--the pattern of the registers
constant REGLEN=length(RPAT)--length of registers
constant OPPAT={0,0,0,0}--each gene (operation pattern) is 4 nums in a sequence
                        --1=mathop,regnum1,regnum2,store-in register
constant OP=1,FROM1=2,FROM2=3,STORE=4--handy refs to OPPAT locs
constant OPLEN=length(OPPAT)--length of OPPAT
constant ANSPAT={0,0,0,0,0,0,0,0}--pattern of answer section of a being
constant PRIVPAT={0,0,0,0,0,0}--private num, bias repeated 3 times 
constant ANSLEN=length(ANSPAT)--length of ANSPAT
constant BEING={RPAT,{OPPAT,OPPAT,OPPAT,OPPAT,OPPAT,OPPAT},PRIVPAT,ANSPAT,RPAT,{}}--basic being
constant REG=1,GENE=2,PRIV=3,ANS=4,ORIGREG=5,STOREREG=6
					--handy refs to being locs (PRIV=private numbers, biases)
					--PRIV for private num and bias (control change of private num)
					--ORIGREG and STOREREG were added on to preserve the steps
					--taken by each gene for the final report.
constant SMALLVAL=.001--answer must be this close to be accepted, set as preferred
constant MAXRUN=1200--max try-sets before restarting
integer mainCnt--common count of generations
constant MINPERF=25--controls minPerformance; larger is less demanding (1/mainCnt*MINPERF)
atom minPerformance--start over if slow evolution: (1/mainCnt*MINPERF) 
constant DEBUG=1 -- 0=debugging off, 1=debugging on (creates DEBUG.TXT)
constant CLEARDEBUGFILE=0--continuous appending=0; clear DEBUG.TXT=1
constant CONTINUOUSRUN=0--controls continuous run of same formula until user exits
constant DEBUGFILE="C:\\EUPHORIA\\DEBUG.TXT"--set as preferred

sequence r--the register
sequence p--the population of beings (each has min of MINGENES OPPATs & up
          --to MINGENES*2)
sequence formula
sequence vars

sequence answers
atom best
integer key,state,runs,completes,freeride
sequence msg,s1,genes,gene,regs
-------------------------------------------------

--=> FILE: misc.e < < < < < < < < < < <

-- Euphoria 2.5
-- Miscellaneous routines and constants

constant LINUX = 3

function reverse(sequence s)
    -- reverse the top-level elements of a sequence.
    -- Thanks to Hawke' for helping to make this run faster.
    integer lower, n, n2
    sequence t
    n = length(s)
    n2 = floor(n/2)+1
    t = repeat(0, n)
    lower = 1
    for upper = n to n2 by -1 do
        t[upper] = s[lower]
        t[lower] = s[upper]
        lower += 1
    end for
    return t
end function

-- pretty print variables

-- trig formulas provided by Larry Gregg

constant PI = 3.141592653589793238

-- this is pi/2

type trig_range(object x)
    -- values passed to arccos and arcsin must be [-1,+1]
    if atom(x) then
        return x >= -1 and x <= 1
    else
        for i = 1 to length(x) do
            if not trig_range(x[i]) then
                return 0
            end if
        end for
        return 1
    end if
end type

--=> FILE: machine.e < < < < < < < < < < <

-- Euphoria 2.5
-- Machine Level Programming (386/486/Pentium)

constant M_ALLOC = 16, M_ALLOC_LOW = 32, M_FREE_LOW = 33,M_INTERRUPT = 34,
M_TICK_RATE = 38

-- biggest address on a 32-bit machine
constant MAX_ADDR = power(2, 32)-1

-- biggest address accessible to 16-bit real mode
constant LOW_ADDR = power(2, 20)-1

type positive_int(integer x)
    return x >= 1
end type

type machine_addr(atom a)
    -- a 32-bit non-null machine address
    return a > 0 and a <= MAX_ADDR and floor(a) = a
end type

type low_machine_addr(integer a)
    -- a legal low machine address
    return a > 0 and a <= LOW_ADDR
end type

type sequence_8(sequence s)
    -- an 8-element sequence
    return length(s) = 8
end type

type sequence_4(sequence s)
    -- a 4-element sequence
    return length(s) = 4
end type

constant REG_LIST_SIZE = 10
constant REG_SI = 2, REG_BX = 4, REG_DX = 5, REG_AX = 7, REG_FLAGS = 8, REG_DS = 10

type register_list(sequence r)
    -- a list of register values
    return length(r) = REG_LIST_SIZE
end type

function allocate(positive_int n)
    -- Allocate n bytes of memory and return the address.
    -- Free the memory using free() below.
    return machine_func(M_ALLOC, n)
end function

function allocate_low(positive_int n)
    -- Allocate n bytes of low memory (address less than 1Mb)
    -- and return the address. Free this memory using free_low() below.
    -- Addresses in this range can be passed to DOS during software interrupts.
    return machine_func(M_ALLOC_LOW, n)
end function

procedure free_low(low_machine_addr a)
    -- free the low memory at address a
    machine_proc(M_FREE_LOW, a)
end procedure

function dos_interrupt(integer int_num, register_list input_regs)
    -- call the DOS operating system via software interrupt int_num, using the
    -- register values in input_regs. A similar register_list is returned.
    -- It contains the register values after the interrupt.
    return machine_func(M_INTERRUPT, {int_num, input_regs})
end function

atom mem
mem = allocate(4)

function bits_to_int(sequence bits)
    -- get the (positive) value of a sequence of "bits"
    atom value, p
    value = 0
    p = 1
    for i = 1 to length(bits) do
        if bits[i] then
            value += p
        end if
        p += p
    end for
    return value
end function

-- Crash handling routines:

procedure tick_rate(atom rate)
    -- Specify the number of clock-tick interrupts per second.
    -- This determines the precision of the time() library routine,
    -- and also the sampling rate for time profiling.
    machine_proc(M_TICK_RATE, rate)
end procedure

-- variables and routines used in safe.e

integer check_calls
check_calls = 1

--=> FILE: sort.e < < < < < < < < < < <

-- Euphoria 2.5
-- Sorting

-- Sort the elements of a sequence into ascending order, using "Shell" sort.

function sort(sequence x)
    -- Sort a sequence into ascending order. The elements can be atoms or
    -- sequences. The standard compare() routine is used to compare elements.
    integer gap, j, first, last
    object tempi, tempj
    last = length(x)
    gap = floor(last / 10) + 1
    while 1 do
        first = gap + 1
        for i = first to last do
            tempi = x[i]
            j = i - gap
            while 1 do
                tempj = x[j]
                if compare(tempi, tempj) >= 0 then
                    j += gap
                    exit
                end if
                x[j+gap] = tempj
                if j <= gap then
                    exit
                end if
                j -= gap
            end while
            x[j] = tempi
        end for
        if gap = 1 then
            return x
        else
            gap = floor(gap / 3.5) + 1
        end if
    end while
end function

--=> FILE: file.e < < < < < < < < < < <

-- Euphoria 2.5
-- Directory and File Operations --

constant M_DIR = 22, M_ALLOW_BREAK = 42, M_CHECK_BREAK = 43

type boolean(integer b)
    return b = 0 or b = 1
end type

function dir(sequence name)
    -- returns directory information, given the name
    -- of a file or directory. Format returned is:
    -- {
    -- {"name1", attributes, size, year, month, day, hour, minute, second},
    -- {"name2", ... },
    -- }
    return machine_func(M_DIR, name)
end function

procedure allow_break(boolean b)
    -- If b is TRUE then allow control-c/control-break to
    -- terminate the program. If b is FALSE then don't allow it.
    -- Initially they *will* terminate the program, but only when it
    -- tries to read input from the keyboard.
    machine_proc(M_ALLOW_BREAK, b)
end procedure

function check_break()
    -- returns the number of times that control-c or control-break
    -- were pressed since the last time check_break() was called
    return machine_func(M_CHECK_BREAK, 0)
end function

-- Generalized recursive directory walker

-- error code

integer SLASH
if platform() = LINUX then
    SLASH='/'
else
    SLASH='\\'
end if

-- override the dir sorting function with your own routine id
constant DEFAULT = -2
integer my_dir
-- it's better not to use routine_id() here,
my_dir = DEFAULT
-- or else users will have to bind with clear routine names


--=> FILE: get.e < < < < < < < < < < <

-- Euphoria 2.5
-- Input and Conversion Routines:
-- get()
-- value()
-- wait_key()

-- error status values returned from get() and value():

constant M_WAIT_KEY = 26

constant TRUE = 1

type natural(integer x)
    return x >= 0
end type

type char(integer x)
    return x >= -1 and x <= 255
end type

-- file to be read from

-- string to be read from

-- the current character

function wait_key()
    -- Get the next key pressed by the user.
    -- Wait until a key is pressed.
    return machine_func(M_WAIT_KEY, 0)
end function

--=> FILE: wildcard.e < < < < < < < < < < <

-- Euphoria 2.5
-- wild card matching for strings and file names

constant TO_LOWER = 'a' - 'A'

function lower(object x)
    -- convert atom or sequence to lower case
    return x + (x >= 'A' and x <= 'Z') * TO_LOWER
end function

function upper(object x)
    -- convert atom or sequence to upper case
    return x - (x >= 'a' and x <= 'z') * TO_LOWER
end function

--=> FILE: graphics.e < < < < < < < < < < <

-- Euphoria 2.5
-- Graphics & Sound Routines


-- COLOR values -- for characters and pixels
constant BLACK = 0, GREEN = 2, BRIGHT_GREEN = 10, BRIGHT_MAGENTA = 13, BRIGHT_WHITE = 15
integer BLUE, CYAN, RED, BROWN, BRIGHT_BLUE, BRIGHT_CYAN, BRIGHT_RED, YELLOW

if platform() = LINUX then
    BLUE = 4
    CYAN = 6
    RED = 1
    BROWN = 3
    BRIGHT_BLUE = 12
    BRIGHT_CYAN = 14
    BRIGHT_RED = 9
    YELLOW = 11
else
    BLUE = 1
    CYAN = 3
    RED = 4
    BROWN = 6
    BRIGHT_BLUE = 9
    BRIGHT_CYAN = 11
    BRIGHT_RED = 12
    YELLOW = 14
end if

-- add to color to get blinking text

-- machine() commands
constant M_SOUND = 1, M_GRAPHICS_MODE = 5, M_SET_T_COLOR = 9,
M_SET_B_COLOR = 10, M_TEXTROWS = 12, M_VIDEO_CONFIG = 13, M_GET_POSITION = 25

type mode(integer x)
    return (x >= -3 and x <= 19) or (x >= 256 and x <= 263)
end type

type color(integer x)
    return x >= 0 and x <= 255
end type

function graphics_mode(mode m)
    -- try to set up a new graphics mode
    -- return 0 if successful, non-zero if failed
    return machine_func(M_GRAPHICS_MODE, m)
end function

constant VC_LINES = 3, VC_COLUMNS = 4
function video_config()
    -- return sequence of information on video configuration
    -- {color?, mode, text lines, text columns, xpixels, ypixels, #colors, pages}
    return machine_func(M_VIDEO_CONFIG, 0)
end function

-- cursor styles:

function get_position()
    -- return {line, column} of current cursor position
    return machine_func(M_GET_POSITION, 0)
end function

function text_rows(positive_int rows)
    return machine_func(M_TEXTROWS, rows)
end function

procedure text_color(color c)
    -- set the foreground text color to c - text or graphics modes
    -- add 16 to get blinking
    machine_proc(M_SET_T_COLOR, c)
end procedure

procedure bk_color(color c)
    -- set the background color to c - text or graphics modes
    machine_proc(M_SET_B_COLOR, c)
end procedure

-- Sound Effects --

type frequency(integer x)
    return x >= 0
end type

procedure sound(frequency f)
    -- turn on speaker at frequency f
    -- turn off speaker if f is 0
    machine_proc(M_SOUND, f)
end procedure
--=> FILE: qconsts.e < < < < < < < < < < <
--qconsts.e
--Author: Quark 9/99
--Purpose: put or list all commonly-used constants in one *.e file
----------------------------------
constant FALSE=0
constant EOF = -1
constant NOPROBLEM=TRUE,PROBLEM=FALSE
constant HORIZONTAL=0
constant VERTICAL=1
constant CENTER=2
constant BOTH=2
constant DEFAULTFORECOLOR=GREEN
constant DEFAULTBACKCOLOR=BLACK
integer MAXROW,MAXCOL
sequence TOPRC, MAINRC, BOTRC
constant BOXLEFT=1
constant BOXCENTER=2
constant BOXRIGHT=3
constant BOXOFFSET=4
constant SHORTPAUSE=150
--global box parts constants:
constant PART={"ÉÍÍÍ»", "º   º", "ÌÍË͹", "ÌÍÎ͹", "ÈÍÊͼ"}
----------------------------------
--section of constants from D. Cuny's keys.e

-- key definitions

constant BACKSPACE = 8, ENTER = 13, ESC = 27,LEFT = 331, RIGHT = 333
--end section of constants from D. Cuny's keys.e
----------------------------------
--=> FILE: qtypes.e < < < < < < < < < < <
--qtypes.e
--Author: Quark 9/99
--Purpose: Put useful types together
--================================
type isLetter(atom a)
    if (a>='A'and a<='Z') or (a>='a'and a<='z') or a='_' then
        return TRUE
    else
        return FALSE
    end if
end type
--============================
type isNumber(atom a)
    if a>='0'and a<='9' then
        return TRUE
    else
        return FALSE
    end if
end type
--============================
type isPrintable(atom a)
    if a>31 and a<127 then
        return TRUE
    else
        return FALSE
    end if
end type
--============================
type String(object s)
    --Is the object an Eu string?
    if atom(s) then
        return 0
    elsif sequence(s) and equal(s,{}) then
        return 1
    else
        for i=1 to length(s) do
            if not integer(s[i]) then return 0 end if
            if equal(s[i],9) or equal(s[i],10) or equal(s[i],13) or s[i]>31 and s[i]<255 then
                --do nothing
            else
                return 0
            end if
        end for
    end if
    return 1
end type
--================================

--=> FILE: qfile.e < < < < < < < < < < <

--============================================================
--qfile.ex
--Quark 8/05
--License: free use and user-responsible - no restrictions on use, except
--retain comments within routines.
--Long filename support for DOS 7.1 and up
--============================================================
function ExistFile(sequence fullPath)
    --Author: Generic - returns 1 if file exists, 0 otherwise
    if atom(dir(fullPath)) then
        return 0
    end if
    return 1
end function
--============================================================
function StripAll(sequence s)
    --Author: Generic - Strip all chars <33 from everywhere in the string
    sequence t
    t={}
    for i=1 to length(s) do
        if s[i]>32 and s[i]<256 then
            t&=s[i]
        end if
    end for
    return t
end function
--============================================================
function CheckLFNS()
    --Author Generic - Returns 0=no long filename support, 1=DOS7.1 and higher
    -- Returns 2 if WinNT, Win2K, WinME, WinXP (has cmd.exe)
    sequence regs
    regs=repeat(0,10)
    if ExistFile("c:\\windows\\system32\\cmd.exe")then
        return 2
    else
        regs[REG_AX]=#3306
        regs=dos_interrupt(#21,regs)
        if and_bits(regs[REG_BX],#00FF)<7 or
            and_bits(regs[REG_BX],#00FF)=7 and
            and_bits(regs[REG_BX],#FF00)<#0A then
            return 0
        end if
    end if
    return 1
end function
--============================================================
function lowCase(sequence s)
    --Author: Generic - returns string with letters lowercase
    integer dif
    dif='a'-'A'
    for i=1 to length(s) do
        if s[i]>='A' and s[i]<='Z' then
            s[i]=s[i]+dif
        end if
    end for
    return s
end function
--============================================================
function Tok(sequence s,sequence delimeters)
    --Quark: Return list of all tokens (chars between delimeters) in s
    sequence list,token
    token={}
    list={}
    for i=1 to length(s) do
        if not find(s[i],delimeters) then
            token&=s[i]
        else
            if length(token) then
                list=append(list,token)
                token={}
            end if
        end if
    end for
    if length(token) then
        list=append(list,token)
    end if
    return list
end function
--============================================================
function DOSDirName(sequence s)
    --Author: Generic - returns stripped string clipped to length 8
    s=StripAll(s)
    if length(s)>8 then
        return s[1..8]
    end if
    return s
end function
--============================================================
function DOSFileName(sequence fName)
    --Quark 8/05 Minor function that cleans a possibly mal-formed DOS filename
    --Example: if s="weird name.txt" it would return "weirdnam.txt"
    sequence t,name,ext
    --Strip all <33 and tokenize on '.'
    t=Tok(StripAll(fName),".")
    name=t[1]
    ext=""
    if equal(length(t),2) then
        ext='.'&t[2]
    end if
    if length(ext)>4 then
        ext=ext[1..4]
    end if
    return name[1..8]&ext
end function
--============================================================
function DOSPath(sequence fullPath)
    --Author: Quark 8/05 Minor function to force a fullpath to conform to the
    --DOS eight char dir pattern and eight.three char file pattern
    sequence t1,t2
    t2={}
    t1=Tok(lowCase(fullPath),"\\")
    if find(":",t1[1])then
        t2&=t1[1]
        t1=t1[2..$]
    end if
    if equal(length(t1),1) then
        return t2&"\\"&DOSFileName(t1[1])
    elsif length(t1)>1 then
        for i=1 to length(t1)-1 do
            t2&='\\'&DOSDirName(t1[i])
        end for
        t2&="\\"&DOSFileName(t1[$])
    else
        return t2
    end if
    return t2
end function
--============================================================
function Open(sequence fullPath,sequence how)
    --Quark 8/05 Handle file open using long file names support
    --Uses Eu open() command, returns file handle or -1 on fail.
    integer lowBuf
    sequence dQ,regs
    dQ="\""
    regs=repeat(0,10)
    --if cmd.exe exists
    if CheckLFNS() then
        if not ExistFile(fullPath) then
            --Thanks to Ralf Brown and RDS
            lowBuf=allocate_low(#80)
            regs[REG_AX]=#716C
            regs[REG_BX]=bits_to_int({0,1,0})
            regs[REG_DX]=bits_to_int({0,0,0,0,1})
            regs[REG_FLAGS]=#1
            regs[REG_DS]=floor(lowBuf/16)
            regs[REG_SI]=remainder(lowBuf,16)
            poke(lowBuf,fullPath)
            poke(lowBuf+length(fullPath),0)
            regs=dos_interrupt(#21,regs)
            free_low(lowBuf)
            --CF clear on success - close file
            if not and_bits(regs[REG_FLAGS],#1) then
                regs[REG_FLAGS]=#1
                --move handle to BX
                regs[REG_BX]=regs[REG_AX]
                --call file close
                regs[REG_AX]=#3E00
                regs=dos_interrupt(#21,regs)
                --CF clear on success
                if and_bits(regs[REG_FLAGS],#1) then
                    puts(1,"\nCould not close file in Open()\n")
                end if
            end if
        end if
    else
        --no long filename support, try abbreviated path
        fullPath=DOSPath(fullPath)
    end if
    return open(fullPath,how)
end function
--============================================================

--=> FILE: qtext.e < < < < < < < < < < <

--==========================================================================
--qtext.e
--By Quark 8/99 and after - A set of Quark-written or gathered text routines
--==========================================================================
function abs(atom a)
    --Author: Generic - Return absolute of a
    if a<0 then return -a end if
    return a
end function
--===========================================================================
--begin section of code borrowed from D. Cuny's keys.e
--
-- Extended Key Handling Routines v2.2
-- David Cuny 11/22/97
-- Internet: dcuny@hw1.cahwnet.gov
--
-- Bit optimization suggested by Robert Craig
-- Mouse events added
-- Alt+Gr key support
--
--borrowed, stripped mouse functions out Quark 12/02

-- allow/disallow type ahead
--::::::::::::::::::::::::::::::::::::::

-- cursor position
sequence cursorPosition
cursorPosition = get_position()

-- key state stuff

-- edit mode
integer editMode
constant INSERT_MODE = 0

-- default mode
editMode = INSERT_MODE

-- last key pressed
----------------------------------------------------------------------------
--end section of code borrowed from D. Cuny's keys.e
--::::::::::::::::::::::::::::::::::::::
function GetVideo()
    --Author: Generic - graphics mode, text rows, text columns, xpixels,
    --ypixels, number of colors, number of pages}
    return video_config()
end function
--::::::::::::::::::::::::::::::::::::::
function SetScreenMode(integer m)
    --Author: Generic - Returns 0=success, 1=failure
    return graphics_mode(m)
end function
--::::::::::::::::::::::::::::::::::::::
procedure SetTick()
    --Author: Generic - Set tick rate to 100
    tick_rate(100)
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure ClearTick()
    --Author: Generic - Clear tick rate
    tick_rate(0)
end procedure
--::::::::::::::::::::::::::::::::::::::
function GetTextCols()
    --Author: Generic - Return text columns
    sequence s1
    s1=GetVideo()
    return s1[VC_COLUMNS]
end function
--::::::::::::::::::::::::::::::::::::::
function GetTextRows()
    --Author: Generic - Return text-rows num
    sequence s1
    s1=GetVideo()
    return s1[VC_LINES]
end function
--::::::::::::::::::::::::::::::::::::::
function SetTextRows(integer m)
    --Author: Generic - Set num of text-rows
    --Returns text row number actually available
    return text_rows(m)
end function
--::::::::::::::::::::::::::::::::::::::
procedure SetForeColor(integer c)
    --Author: Generic - Set fore color
    text_color(c)
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure SetBackColor(integer c)
    --Author: Generic - Set backgnd color
    bk_color(c)
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure ScreenColors(integer f,integer b)
    --Author Generic - Set fore and back colors
    SetForeColor(f)
    SetBackColor(b)
    clear_screen()
end procedure
--============================================================================
function Pad(sequence s,integer len,integer mode)
    --Author: Quark
    --Input:1 or many textlines, desired length, mode=LEFT,RIGHT,BOTH
    --Output:1 or many padded lines (padded with spaces)
    --Note: Will clip to length len if length(line)>len
    integer x,y,z
    if not length(s) then
        s={" "}
    end if
    if atom(s[1]) then
        s={s}
    end if
    for i=1 to length(s) do
        if equal(s[i],{}) then
            s[i]={32}
        end if
        if length(s[i])>len then
            s[i]=s[i][1..len]
        end if
        if length(s[i])<len then
            x=length(s[i])
            if equal(mode,LEFT) then
                s[i]=repeat(' ',len-x)&s[i]
            elsif equal(mode,RIGHT) then
                s[i]=s[i]&repeat(' ',len-x)
            elsif equal(mode,BOTH) then
                y=floor((len-x)/2)
                z=remainder(len-x,2)
                s[i]=repeat(' ',y+z)&s[i]&repeat(' ',y)
            end if
        end if
    end for
    if equal(length(s),1) then
        return s[1]
    else
        return s
    end if
end function
--::::::::::::::::::::::::::::::::::::::
procedure PlaceLineAt(sequence RC,object o)
    --Author: Quark: Screen-print a line of chars.
    -- RC={r1,c1,r2,c2}; o=chars sequence or atom; hv=orientation (horiz, vert)
    -- If length(o)<4, then assume box-line & generate it, else string.
    integer len,lenO,hv
    if RC[1]=RC[3] then
        -- Is it horizontal?
        hv=HORIZONTAL
    else
        hv=VERTICAL
        -- No, vertical.
    end if
    if atom(o) then
        o={o}
    end if
    if hv=HORIZONTAL then
        len=RC[4]-RC[2]+1
    else
        len=RC[3]-RC[1]+1
    end if
    lenO=length(o)
    if lenO=0 then
        o=repeat(' ',len)
    elsif lenO=1 then
        o=repeat(o[1],len)
    elsif lenO=2 then
        o=o[1]&repeat(o[2],len-1)
    elsif lenO=3 then
        o=o[1]&repeat(o[2],len-2)&o[3]
    else
        if lenO>len then
            o=o[1..len]
        end if
        if lenO<len then
            o=Pad(o,len,CENTER)
        end if
    end if
    if hv=HORIZONTAL then
        --horizontal
        position(RC[1],RC[2])
        puts(1,o)
    else
        for i=1 to length(o) do
            position(RC[1]+i-1,RC[2])
            puts(1,o[i])
        end for
    end if
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure PlaceAt(sequence RC,object o)
    --Author: Quark: multi-purpose screen-print function: if RC is length 2, then print
    -- normally; else, use the elaborate PlaceLineAt() function.
    if length(RC)=2 then
        position(RC[1],RC[2])
        puts(1,o)
    else
        PlaceLineAt(RC,o)
    end if
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure CenterAt(integer lineNum,sequence s)
    --Author: Quark - Center a line using padding. Use line #0 
	--if line is pre-positioned.
    sequence at
    if equal(s,{}) then
        --do nothing
    else
        if lineNum=0 then
            at=get_position()
            lineNum=at[1]
        end if
        PlaceAt({lineNum,2,lineNum,GetTextCols()-1},s)
    end if
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure BlankLine(integer lineNum)
    --Author: Quark - Print a blank line at lineNum
    PlaceAt({lineNum,2,lineNum,GetTextCols()-1}," ")
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure Wait(atom increment)
    --Author: Generic - Wait up to 10 seconds
    --Protected agains time() rollover
    --increment is given in 1/100ths of a second
    atom timer
    if increment>1000 then increment=1000 end if
    increment/=100
    timer=time()+increment
    while time()<timer do
        --protect against clock() starting over
        if abs(timer-time())>increment then
            timer=time()+increment
        end if
    end while
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure Pause(sequence msg,integer mode)
    --Quark: multi-function Pause (Assumes tick_rate is 100
    --if mode=-1 then print nothing, just wait until a key is pressed
    --if mode=0 then print msg on message line & wait for key-press
    --else print msg & wait for mode hundredths of a second, erase message
    integer chk
    MAXROW=GetTextRows()
    chk=0
    if check_break() then
        puts(2,"Aborting from Pause via Ctrl-C...")
        abort(1)
    end if
    if equal(mode,-1) then
        while not wait_key() do
        end while
    elsif equal(mode,0) then
        CenterAt(MAXROW,msg)
        while not wait_key() do
        end while
    else
        CenterAt(MAXROW,msg)
        Wait(mode)
        BlankLine(MAXROW)
    end if
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure Hello()
    --Author: Quark - Set up default behavior
    MAXROW=SetTextRows(50)
    ScreenColors(DEFAULTFORECOLOR,DEFAULTBACKCOLOR)
    SetTick()
    allow_break(0)
    Pause("Hello...",75)
    MAXCOL=GetTextCols()
    TOPRC={1,1,3,MAXCOL}
    MAINRC={4,1,MAXROW-4,MAXCOL}
    BOTRC={MAXROW-3,1,MAXROW-1,MAXCOL}
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure Goodbye()
    --Author: Quark - Prepare for ending program, end it.
    integer x
    Pause("Bye...",75)
    x=SetScreenMode(-1)
    ClearTick()
    clear_screen()
    abort(0)
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
function Next(sequence s)
    --Author: Quark - Step through a global sequence of correct form
    --Purpose: return next o compared to last one returned; circular
    --Input: sequence of form {{o,o,..o},0}
    --Output: s; sets integer s[2] to position of current o, such that
    -- x=Next(s) gives next member of s[1] which reads as s[1][s[2]]
    integer len
    len=length(s[1])
    if s[2]<1 or s[2]>=len then
        s[2]=1
        return s
    else
        s[2]+=1
        return s
    end if
end function
--::::::::::::::::::::::::::::::::::::::
function GetLongestLineLength(sequence s)
    --Author: Generic - return longest line length from lines in s
    integer x
    x=0
    for i=1 to length(s) do
        if x<length(s[i]) then
            x=length(s[i])
        end if
    end for
    return x
end function
--::::::::::::::::::::::::::::::::::::::
function TextOffset(sequence s, integer maxCol)
    --Author:Generic - Return offset for evenly printing lines based on
    --the maximum columns available and the longest line in the set of lines
    return floor((maxCol-GetLongestLineLength(s))/2)
end function
--::::::::::::::::::::::::::::::::::::::
function StripCR(sequence s)
    --Quark 4/02
    --For both Unix and Microsoft EOLs
    --Strips the EOL and returns it and the stripped line
    --Assumes EOL marker is at end of line
    --Can handle string without EOL
    --12/02 can handle many strings
    object CR
    CR='\n'
    if equal(s,{}) then
        s={CR}
    end if
    if atom(s[1]) then
        CR={}
        if match({10,13},s) then
            CR={13,10}
        elsif match({13},s) then
            CR={13}
        elsif match({10},s) then
            CR={10}
        end if
        if length(s) and length(s)>length(CR) then
            return{CR,s[1..length(s)-length(CR)]}
        end if
        return {CR,{}}
    else
        for i=1 to length(s) do
            if equal(s[i],{}) then
                s[i]={CR}
            end if
            CR={}
            if match({10,13},s[i]) then
                CR={13,10}
            elsif match({13},s[i]) then
                CR={13}
            elsif match({10},s[i]) then
                CR={10}
            end if
            if length(s[i]) and length(s[i])>length(CR) then
                s[i]=s[i][1..length(s[i])-length(CR)]
            else
                s[i]={}
            end if
        end for
        return {CR,s}
    end if
end function
--::::::::::::::::::::::::::::::::::::::
procedure Delay(integer m)
    atom t
    t=m
    t=t/100+time()
    while t>time() do
    end while
end procedure
--::::::::::::::::::::::::::::::::::::::
procedure Box(sequence RC)
    --Quark: plain box. RC={r1,c1,r2,c2}
    object o
    sequence rc
    SetForeColor(DEFAULTFORECOLOR)
    --Top line
    rc={RC[1],RC[2],RC[1],RC[4]}
    --span between cordinates
    o={PART[1][1],PART[1][2],PART[1][5]}
    -- top line
    PlaceAt(rc,o)
    -- Print line
    --Verical lines
    rc={RC[1]+1,RC[2],RC[3]-1,RC[2]}
    -- 1st vertical
    o=PART[2][1]
    PlaceAt(rc,o)
    rc={RC[1]+1,RC[4],RC[3]-1,RC[4]}
    -- 2nd vertical
    PlaceAt(rc,o)
    --Bottom line
    rc={RC[3],RC[2],RC[3],RC[4]}
    --bottom line
    o={PART[5][1],PART[1][2],PART[5][5]}
    -- bottom line
    PlaceAt(rc,o)
end procedure
--===========================================================================
function Pretty(object o)
    --Quark 7/05 (reinventing the wheel)
    --turn any object into a string
    sequence t, t2
    t={}
    t2={}
    if atom(o) then
        return sprintf("%g",o)&' '
    elsif sequence(o) then
        if String(o) then
            return o&' '
        else
            for i=1 to length(o) do
                t&=Pretty(o[i])
            end for
            t&=' '
        end if
    end if
    return t
end function
--===========================================================================
function PrettyAll(sequence all)
    --Format sequences of any kind into strings with returns
    for i=1 to length(all) do
        if String(all[i]) then
            if equal(all[i],{}) then
                all[i]={'\n'}
            else
                if not equal(all[i][$],'\n') then
                    all[i]&='\n'
                end if
            end if
        else
            all[i]=Pretty(all[i])
            if equal(all[i],{}) then
                all[i]={'\n'}
            elsif equal(all[i][$],' ') then
                all[i][$]='\n'
            else
                all[i]&='\n'
            end if
        end if
    end for
    return all
end function
--::::::::::::::::::::::::::::::::::::::
function AppendFile(sequence fullPath,sequence s, sequence msg)
    --Quark 7/05
    --Purpose: append strings to a file. Converts any object to a string, 
    --so this is good for debugging.
    --Input: fullPath, sequence of strings or objects, msg 
	--(makes a header if msg is not empty
    integer fn
    if length(msg) then
        msg=repeat('-',50)&'\n'&msg&'\n'&repeat('-',50)&'\n'
        s=msg&PrettyAll(s)
    else
        s=PrettyAll(s)
    end if
    fn=Open(fullPath,"a")
    if (fn=EOF) then
        return PROBLEM
    else
        for i=1 to length(s) do
            puts(fn,s[i])
        end for
        close(fn)
    end if
    return NOPROBLEM
end function
--::::::::::::::::::::::::::::::::::::::
function ClearFile(sequence fPath)
    --Quark: Clear the file
    integer fn
    fn=Open(fPath,"w")
    if (fn=EOF) then
        Pause(" ClearFile: "&fPath&" failed--Press key",0)
        return PROBLEM
    end if
    close(fn)
    return NOPROBLEM
end function
--===========================================================================

--=> FILE: qfs.e < < < < < < < < < < <

--**************************************
--qfs.e in Euphoria
--A PC DOS-based include file
--By Quark (DB James) - 08/15/99
--Purpose: Develop basic file select routine
--**************************************
integer oldTColor,oldBColor
sequence curHue
sequence temp
--======================================
--oldTColor=vc[VC_COLOR]
oldTColor=BRIGHT_GREEN
oldBColor=BLACK
curHue={GREEN,BLACK,BRIGHT_GREEN,BLACK}
temp={}
for i='A' to 'Z' do
    temp=append(temp,repeat(i,5))
end for
--======================================

--=> FILE: box.e < < < < < < < < < < <

--**************************************
--box.e in Euphoria
--By Quark (DB James) - 6/10/2002
--Purpose: provide a box-based gui
--**************************************
--======================================
integer gi1

--global integer flowStart --For FlowBox()
sequence flowText
--======================================
--Definitions
flowText={}
--======================================
--Procedures & Functions
--:::::::::::::::::::::::::::::::::::::::::::::::
procedure Eek()
    sound(2000)
    Delay(1)
    sound(0)
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
procedure PrintBoxLines(sequence rc,sequence s,integer c,integer mode)
    --Input: a text-area's rc sequence, e.g. {1,1,20,10}
    -- s=one or more lines of text
    -- c=forecolor
    --Trucates lines too long & chops off excess lines
    integer w,h,x1,x2
    sequence s1
    w=rc[4]-rc[2]+1
    h=rc[3]-rc[1]+1
    if atom(s) or equal(s,{}) then
        s={" "}
    elsif atom(s[1]) then
        s={s}
    end if
    for i=1 to length(s) do
        s1=StripCR(s[i])
        s[i]=s1[2]
        if equal(s[i],{}) then
            s[i]=" "
        end if
    end for
    for i=1 to length(s) do
        if length(s[i])>w then
            s[i]=s[i][1..w]
        end if
    end for
    if length(s)>h then
        s=s[1..h]
    end if
    if mode=BOXLEFT then
        for i=1 to length(s) do
            s[i]=Pad(s[i],w,RIGHT)
        end for
    elsif mode=BOXCENTER then
        for i=1 to length(s) do
            s[i]=Pad(s[i],w,CENTER)
        end for
    elsif mode=BOXRIGHT then
        for i=1 to length(s) do
            s[i]=Pad(s[i],w,LEFT)
        end for
    else
        x2=TextOffset(s,w)
        for i=1 to length(s) do
            s[i]=repeat(' ',x2)&s[i]
            s[i]=Pad(s[i],w,RIGHT)
            gi1=length(s[i])
        end for
    end if
    SetForeColor(c)
    x1=0
    for i=rc[1] to rc[3] do
        x1+=1
        if x1<=length(s) then
            position(i,rc[2])
            puts(1,s[x1])
        else
            exit
        end if
    end for
    SetForeColor(DEFAULTFORECOLOR)
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
procedure OutBox(sequence rc,sequence s,integer c,integer mode)
    --Input: a box's rc sequence, e.g. {1,1,20,10}
    -- s=one or more lines of text
    -- c=forecolor
    --Trucates lines too long & chops off excess lines
    Eek()
    Box(rc)
    PrintBoxLines({rc[1]+1,rc[2]+1,rc[3]-1,rc[4]-1},s,c,mode)
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
procedure TitleBox(sequence s,integer c)
    OutBox(TOPRC,s,c,BOXCENTER)
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
procedure BlankBox(sequence rc)
    sequence s1
    s1=""
    if length(rc)=4 then
        s1=repeat(32,rc[4]-rc[2]-1)
        for i=rc[1]+1 to rc[3]-1 do
            position(i,rc[2]+1)
            puts(1,s1)
        end for
    else
        puts(1,"Input error to BlankBox: needs rc=dimensions of actual box.")
    end if
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
procedure MainBox(sequence s,integer c)
    BlankBox(MAINRC)
    OutBox(MAINRC,s,c,BOXOFFSET)
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
procedure MsgBox(sequence s,integer c)
    OutBox(BOTRC,s,c,BOXCENTER)
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
procedure PauseBox(sequence s,integer c, integer mode)
    --Input s=msg, c=color, mode=-1 (no mesg, wait; 0=msg, wait
    -- num>0 means wait mod/100 sec (100=1 sec)
    integer key
    if length(s)=2 and atom(s[2]) then
        --Added to allow data lines to contain pauselength
        mode=s[2]
        s=s[1]
    end if
    if mode<0 then
        s=""
    end if
    OutBox(BOTRC,s,c,BOXCENTER)
    if mode<1 then
        key=-1
        while equal(key,-1) do
            key=get_key()
            if check_break() then
                PauseBox("BREAK!  Exiting immediately.",BRIGHT_RED,SHORTPAUSE)
                Goodbye()
            end if
        end while
    else
        Delay(mode)
        if check_break() then
            PauseBox("BREAK!  Exiting immediately.",BRIGHT_RED,SHORTPAUSE)
            Goodbye()
        end if
    end if
    MsgBox(" ",BLACK)
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::
function ResponseBox(sequence s,sequence test,integer c)
    --Input: s=message; c=forecolor;test=test sequence for user input
    --Output: key pressed
    -- Only accepts key in sequence test + ESC (also responds to CTRL-C
    integer k,x
    MsgBox(s,c)
    x=0
    while not x do
        if check_break() then
            PauseBox("BREAK!  Exiting immediately.",BRIGHT_RED,SHORTPAUSE)
            Goodbye()
        end if
        k=upper(wait_key())
        x=find(k,test&ESC)
    end while
    return k
end function
--:::::::::::::::::::::::::::::::::::::::::::::::
function InBox(sequence s, integer len, integer c)
    --Input: s=Msg, len=max length of the text response; c=color
    --Output: text response
    --This code modified from D. Cuny's Input()
    integer key,rr,cc
    sequence text
    text={}
    OutBox(BOTRC,s,c,BOXLEFT)
    rr=MAXROW-2
    while TRUE do
        cc=length(s)+2
        position(rr,cc)
        puts(1,text&repeat('_',len-length(text)))
        position(rr,cc+length(text))
        key=wait_key()
        if key=ESC then
            text=""
            exit
        elsif key=ENTER then
            exit
        elsif key = BACKSPACE then
            -- handle backspace
            if length( text ) > 0 then
                -- remove the last character from the text
                text = text[1..length(text)-1]
            end if
        elsif key >= ' ' and key <= '~' then
            -- handle "normal" key
            if length( text ) < len then
                text = text & key
            end if
        else
            -- ignore key
        end if
    end while
    --s1=Input(len)
    MsgBox(" ",BLACK)
    return text
end function
--::::::::::::::::::::::::::::::::::::::
procedure CheckState(integer state,sequence msg)
    --Quark 7/05
    --Purpose: to exit the program if state shows there is a serious problem (usually a file problem)
    if equal(state, PROBLEM) then
        PauseBox(msg&" ...any key",BRIGHT_RED,0)
        PauseBox("Exiting...",BRIGHT_RED,200)
        Goodbye()
    end if
end procedure
--:::::::::::::::::::::::::::::::::::::::::::::::

--=> FILE: ParseEu.e < < < < < < < < < < <

--***************************************************************************
--ParseEu.e - a Euphoria include file
--By Quark - 6/05
--Purpose: Collection of file and Eu parsing routines
--***************************************************************************

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
type Alpha(integer c)
    return (c>='a' and c<='z') or (c>='A' and c<='Z')
end type

--=> FILE: GA-Math.ex < < < < < < < < < < <

--GA-Math.ex Quark 9/05
-------------------------------------------------
function RandRangeDec(integer lo, integer hi)
	return rand(hi-lo+1)+lo-1 + rand(999)/1000
end function
-------------------------------------------------
function CreatePop()
	--Quark 9/05
    integer x
    p=repeat(BEING,POPNUM)
    for i=1 to POPNUM do
        --Add from 0 to MINGENES genes to a being (i.e. if MINGENES=6 then
        -- a being would have from 6 to 12 genes)
        x=rand(MINGENES+1)-1
        if x then
            for j=1 to x do
                p[i][GENE]=append(p[i][GENE],OPPAT)
            end for
        end if
    end for
    return p
end function
-------------------------------------------------
function GetFormula()
	--Quark 9/05
    integer x,cnt
    sequence f,t
    f=InBox("Enter formula: (e.g. c=3.14159*r*2): ",40,YELLOW)
	--for easy run of a given formula, comment out the line above and insert
	--line as the examples below: 
    --f="c=3.14159*r+r"
    --f="v=l*w*h"
	--f="4*3.14159*r*r"--harder (area of sphere)
	--f="v=4/3*3.14159*(r^3)"--harder (volume of a sphere)
	--f="a=3*r*r"--Al Getz' formula
	--f="a=3.14*r*r"--Al Getz' formula
	--f="a=3.14159*r*r"--Al Getz' formula
	--f="x=2*a*3*b*4*c"
	--f="a=x^.5"--fails consistently
	--f="a=100*x"
	--f="a=3.14159*(r^2)"--area of circle
	--f="a=2*x-(3*y)"
	--f="a=(x-y)/z"
	--f="a=(2*x-y)/z"
	--f="a=(2*x-(3*y))/z"
	--f="a=(2*x-(3*y))/(4*z)"
    f=StripAll(f)
    x=find('=',f)
    if not x then
		x=0
    end if
    cnt=2
	t={}
    for i=x+1 to length(f) do
        if Alpha(f[i]) then
			if not find(f[i],t) then
				t&=f[i]
            	cnt+=1
			end if
        end if
    end for
    return {f,t}
end function
-------------------------------------------------
function CreateGenes(sequence p,sequence vars)
	--Quark 9/05
	integer cnt
    for i=1 to length(p) do
        for j=1 to length(p[i][GENE]) do
            p[i][GENE][j][OP]=rand(OPNUM)
            p[i][GENE][j][FROM1]=rand(REGLEN)
            p[i][GENE][j][FROM2]=rand(REGLEN)
            p[i][GENE][j][STORE]=rand(REGLEN)
        end for
		cnt=1
		for j=1 to length(vars) do
	        p[i][PRIV][cnt]=RandRangeDec(0,11)
	        p[i][PRIV][cnt+1]=rand(8)
			cnt+=2
		end for
    end for
    return p
end function
-------------------------------------------------
function RunFormula(sequence formula, sequence vars)
	--Quark 9/05
    --using D. Cuny's eval.e
    integer cnt
    atom answer,ta
    cnt=1
    r=RPAT
    for i=1 to length(vars) do
        if not equal(vars[i],0) then
			ta = RandRangeDec(0,11)
            var[vars[i]]=ta
            r[cnt]=ta
            cnt+=1
        end if
    end for
    answer=eval(formula)
    return {r,answer}
end function
-------------------------------------------------
function FillBeingRegs(sequence p,sequence r)
	--Quark 9/05
	integer cnt,cnt2
	cnt=0
	--count the variables
	for i=1 to length(r) do
		if r[i] then
			cnt+=1
		end if
	end for
    for i=1 to length(p) do
        p[i][REG]=r
        p[i][STOREREG]={}
        --put the being's private number(s) into play
		cnt2=1
		--for each variable, put a private num into register
		for j=cnt+1 to cnt+cnt do
			p[i][REG][j]=p[i][PRIV][cnt2]
			cnt2+=2
		end for
        p[i][ORIGREG]=p[i][REG]
    end for
    return p
end function
-------------------------------------------------
function Animate(sequence p)
	--Quark 9/05
    integer op,from1,from2,store
    atom a
    for i=1 to length(p) do
        for j=1 to length(p[i][GENE]) do
            op=p[i][GENE][j][OP]
            from1=p[i][GENE][j][FROM1]
            from2=p[i][GENE][j][FROM2]
            store=p[i][GENE][j][STORE]
            if op=1 then
                --abs
                p[i][REG][store]=abs(p[i][REG][from1])
            elsif op=2 then
                --reciprocal
                if p[i][REG][from1] then
                    a=1/p[i][REG][from1]
                    p[i][REG][store]=1/p[i][REG][from1]
                    --experiment to make a being "pay" for bad moves
                else
                    p[i][REG][store]=0
                end if
            elsif op=3 then
                --change sign
                --if p[i][REG][from1] then
                p[i][REG][store]=-p[i][REG][from1]
                --end if
            elsif op=4 then
                --add
                p[i][REG][store]=p[i][REG][from1]+p[i][REG][from2]
            elsif op=5 then
                --subtract
                p[i][REG][store]=p[i][REG][from1]-p[i][REG][from2]
            elsif op=6 then
                --multiply
                p[i][REG][store]=p[i][REG][from1]*p[i][REG][from2]
            elsif op=7 then
                --divide
                if not equal( p[i][REG][from2],0 ) then
                    p[i][REG][store]=p[i][REG][from1]/p[i][REG][from2]
                    --experiment to make a being "pay" for bad moves
                else
                    p[i][REG][store]=0
                end if
            elsif op=8 then
                --flatten
                p[i][REG][store]=floor(p[i][REG][from1])
            elsif op=9 then
                --remainder
                if not equal( p[i][REG][from2],0 ) then
                    p[i][REG][store]=remainder(p[i][REG][from1],p[i][REG][from2])
                else
                    --experiment to make a being "pay" for bad moves
                    p[i][REG][store]=0
                end if
			elsif op=10 then
				--decimal fraction
				p[i][REG][store]=p[i][REG][from1]-floor(p[i][REG][from1])
            end if
            p[i][STOREREG]=append(p[i][STOREREG],p[i][REG])
        end for
    end for
    return p
end function
-------------------------------------------------
function RecordAnswer(sequence p,integer cnt)
	--Quark 9/05
    for i=1 to length(p) do
        p[i][ANS][cnt]=p[i][REG][REGLEN]
    end for
    return p
end function
-------------------------------------------------
function AssessResults(sequence p, sequence answers)
	--Quark 9/05
    atom best,n,n1,n2,n3,avg
    sequence t,t2
    t={}
    for i=1 to length(p) do
        --average the exact differences between tries & answers
        n=0
        avg=0
        for j=1 to ANSLEN do
            avg+=abs(answers[j])
            n1=abs(p[i][ANS][j])+abs(answers[j])
            n2=p[i][ANS][j]+n1
            n3=answers[j]+n1
            --calc actual diff
            if n2>n3 then
                n=n+n2-n3
            elsif n3>n2 then
                n=n+n3-n2
            end if
        end for
        n/=ANSLEN
        avg/=ANSLEN
        --store variation between tries and answers as a percent
        --to the abs avg of answers
        t=append(t,{n/avg,i})
    end for
    best=1000000000
    for i=1 to length(t) do
        --put smallest difference in best (best answer)
        if best>t[i][1] then
            best=t[i][1]
        end if
    end for
    --better performers at top of temp list
    t=sort(t)
    t2={}
    --reorder the population according to closeness to the answer
    for i=1 to length(t) do
        t2=append(t2,p[t[i][2]])
    end for
    return {best,t2}
end function
-------------------------------------------------
function HardTimes(sequence p)
	--Quark 9/05 - clone better top half of pop to bottom half with mutations
    integer x,chance,bias
	object copy
    x=floor(length(p)/2)
    for i=1 to x do
        p[i][REG]=RPAT
        p[i][ANS]=ANSPAT
        p[x+i]=p[i]--copy the being
		--each being has multiple private numbers -- mutate clones
		for j=1 to length(p[x+i][PRIV]) by 2 do
	        bias=p[i][PRIV][j+1]
	        --the bias is controlled by p[i][PRIV][j+1] (val range 1-8)
			--change is +/- .001, +/- .0001, +/- .00001
	        if equal(bias,1) then
	            p[x+i][PRIV][j]=p[x+i][PRIV][j]+p[x+i][PRIV][j]/100
	        elsif equal(bias,2) then
	            p[x+i][PRIV][j]=p[x+i][PRIV][j]-p[x+i][PRIV][j]/100
	        elsif equal(bias,3) then
	            p[x+i][PRIV][j]=p[x+i][PRIV][j]+p[x+i][PRIV][j]/1000
	        elsif equal(bias,4) then
	            p[x+i][PRIV][j]=p[x+i][PRIV][j]-p[x+i][PRIV][j]/1000
	        elsif equal(bias,5) then
	            p[x+i][PRIV][j]=p[x+i][PRIV][j]+p[x+i][PRIV][j]/10000
	        elsif equal(bias,6) then
	            p[x+i][PRIV][j]=p[x+i][PRIV][j]-p[x+i][PRIV][j]/10000
	        elsif equal(bias,7) then
	            p[x+i][PRIV][j]=p[x+i][PRIV][j]+p[x+i][PRIV][j]/100000
	        elsif equal(bias,8) then
	            p[x+i][PRIV][j]=p[x+i][PRIV][j]-p[x+i][PRIV][j]/100000
	        end if
	        copy=p[x+i][PRIV][j+1]
	        --chance of a mutation in the bias number
	        if equal(rand(6),rand(6)) then
	            --make sure it really changes
	            while equal(p[x+i][PRIV][j+1],copy) do
	                p[x+i][PRIV][j+1]=rand(6)
	            end while
	        end if
		end for
        for j=1 to length(p[x+i][GENE]) do
	        --mutate, chance is 1:6 a gene alters (in 1 of the 4 gene-components)
            if equal(rand(6),rand(6)) then
                --make sure it really changes
                copy=p[x+i][GENE][j]
                while equal(copy,p[x+i][GENE][j]) do
                    chance=rand(4)
                    if equal(chance,1) then
                        p[x+i][GENE][j][OP]=rand(OPNUM)
                    elsif equal(chance,2) then
                        p[x+i][GENE][j][FROM1]=rand(REGLEN)
                    elsif equal(chance,3) then
                        p[x+i][GENE][j][FROM2]=rand(REGLEN)
                    elsif equal(chance,4) then
                        p[x+i][GENE][j][STORE]=rand(REGLEN)
                    end if
                end while
            end if
        end for
    end for
    return p
end function
-------------------------------------------------
function StripGenes(sequence g, sequence r)
	--Quark 9/05
    --strip irrelevant actions from best being's genes
    integer found,cnt
    sequence t,Gene,Regs
	cnt=1
	--get rid of nop (no-operation)
	while cnt<=length(g) do
		if equal(OPS[g[cnt][1]][1],"nop") then
			g=g[1..cnt-1]&g[cnt+1..$]
			r=r[1..cnt-1]&r[cnt+1..$]
		else
			cnt+=1
		end if
	end while
    --if the operator only uses FROM1 then clip FROM2
    for i=1 to length(g) do
        if equal(OPS[g[i][1]][2],1) then
            g[i]=g[i][1..2]&g[i][$]
        end if
    end for
    g=reverse(g)
    r=reverse(r)
    --clip useless gene components, find first REGLEN in REGLEN register
    --(i.e. only the last storage reg entry is important)
    for i=1 to length(g) do
        if equal(g[i][$],REGLEN) then
            if i>1 then
                g=g[i..$]
                r=r[i..$]
            end if
            exit
        end if
    end for

    t={}
    --add unique registers to temp list
    for i=2 to length(g[1])-1 do
        if not find(g[1][i],t) then
            t&=g[1][i]
        end if
    end for

    --add useful gene components to gene list
    Gene={}
    Regs={}
    Gene=append(Gene,g[1])
    Regs=append(Regs,r[1])
    for i=2 to length(g) do
        found=0
        for j=1 to length(t) do
            if equal(t[j],g[i][$]) then
                --it's a live one
                found=1
                t=t[1..j-1]&t[j+1..$]
                exit
            end if
        end for
        if found then
            Gene=append(Gene,g[i])
            Regs=append (Regs,r[i])
            for j=2 to length(g[i])-1 do
                if not find(g[i][j],t) then
                    t&=g[i][j]
                end if
            end for
        end if
    end for
    return {reverse(Gene),reverse(Regs)}
end function
-------------------------------------------------
function RegToString(sequence r)
	--Quark 9/05
    sequence s
    s="{"
    for i=1 to length(r) do
        if i !=length(r) then
            if not r[i] then
                s&=sprintf("[%1.0f] ",r[i])&", "
            else
                s&=sprintf("[%.2f] ",r[i])&", "
            end if
        else
            if not r[i] then
                s&=sprintf("[%1.0f]",r[i])&"}"
            else
                s&=sprintf("[%.2f]",r[i])&"}"
            end if
        end if
    end for
    return s
end function
-------------------------------------------------
function GeneToString(sequence g)
	--Quark 9/05
    sequence s
    s=""
    s&=OPS[g[1]][1]&", "
    for j=2 to length(g) do
        if not equal(j,length(g)) then
            s&=sprintf("%d",g[j])&", "
        else
            s&=sprintf("%d",g[j])
        end if
    end for
    return s
end function
-------------------------------------------------
--GA-Math.ex Quark 9/05
--Uses a population of GA beings to evolve a formula that yields the correct
--answers to the given inputs. Uses 7 registers. The beings have only the
--ability to apply basic math operations to the register contents. After a
--series of eight trys, the population is halved and that part is then
--regenerated from the genes of the best half.
--Example problem: given Circumference=3.14159*2*r, then the input would be
-- various values of r. The responses of the beings is compared with the
-- answer (the Circumference). The beings are assessed by their closeness
--to the answer.
-------------------------------------------------
sequence hue
hue={{BRIGHT_RED,BRIGHT_BLUE,BRIGHT_CYAN, BRIGHT_MAGENTA,YELLOW,BRIGHT_WHITE},0}
-------------------------------------------------
Hello()
state=NOPROBLEM

if DEBUG and CLEARDEBUGFILE then
    state=ClearFile(DEBUGFILE)
    CheckState(state,"DEBUG:Problem with ClearFile of C:\\EUPHORIA\\Debug.txt")
end if

--Create register
r=RPAT
--create population
p=CreatePop()
--at this point the population is full, but undefined as to personal
--register contents or genes

completes=0

while 1 do
    msg="G e n e t i c  A l g o r i t h m  M a t h"
    for i=1 to length(msg) do
        hue=Next(hue)
        TitleBox(msg[1..i],hue[1][hue[2]])
        Delay(6)
    end for
    if CONTINUOUSRUN then
        msg={ "", "", "","", "Continuous run -- no screen report..." }
        MainBox(msg,BRIGHT_GREEN)
    else
        msg={
"",
		"This Euphoria program is a working Genetic Algorithm program.  It uses",
		"random variation and selection by fitness to create algorithms to solve",
		"math problems.  GA Math attempts to demonstrate evolution in a program.",
		"",
		"The user can type in simple formulas, such as a=l*w or v=l*w*h or",
		"c=3.14159*r+r and the program will generate a population and set it to work",
		"to solve the problem, i.e. it will develop a series of steps to give the",
		"means of arriving at the same answer as the formula itself.",
		"NOTE: use no more than three variables in the formula.",
		"",
		"Please see the constants and comments at the top of the program to see the",
		"structure of the math beings.",
		"",
		"There are many possible improvements to this program.  Currently there are",
		"but 11 operators, such as add, rec (reciprocal), abs (absolute) and chg",
		"(change sign).  (Eval.e by David Cuny is used by this program, and it has",
		"three trig functions I have not used.)  There could be quite a few more,",
		"especially if protection against overflow were added.  Another improvement",
		"would be a good \"translator\" for the steps of the algorithms into succinct",
		"formulas.  On the other hand, it is rather an enjoyable exercise to do the",
		"translation oneself.",
		"",
		"Using the controlling constants at the top of the program, the user can",
		"save output, run continuously to build up a series of different solutions",
		"to a formula, and generally tweak the program's behavior.",
		"",
		"HOW TO ENTER FORMULAS: Formulas are evaluated left to right. Use single",
		"letters for a maximum of three variables, use parentheses to group items.",
		"Examples: a=x*(y+2) or a=3.14159*(r^2) or v=4/3*3.14159*(r^3).",
		"",
		"A final point: I have not tried to mimic natural genetic techniques used by",
		"life to handle evolution.  This is blunt evolution.  To avoid what seems",
		"to be a feature of evolution -- a tendency to \"plateau\" or \"get stuck\" --",
		"I merely restart the process when it isn't performing well.  Two different",
		"mechanisms assure this: MAXRUN and MINPERF (see top of program).",
		"",
		"--Quark"}
        MainBox(msg,BRIGHT_GREEN)
        key=ResponseBox("<C>ontinue or <E>xit  (ESC also exits)","CE",YELLOW)
        if equal(key,'E') or equal(key,ESC) then
            abort(1)
        end if
    end if

    mainCnt=0
    runs=1

    --get the formula
    if CONTINUOUSRUN and completes then
        --do nothing, continue using the current formula
    else
        formula=GetFormula()
        vars=formula[2]
        formula=formula[1]
    end if

    --Create initial genes for the population
    p=CreateGenes(p,vars)

    --go
    minPerformance=1000
    best=minPerformance-1
    while 1 do
        if mainCnt<MAXRUN and best<=minPerformance then
            answers={}
            mainCnt+=1
            for i=1 to ANSLEN do
                --run the formula, return registers and the answer
                r=RunFormula(formula, vars)
                answers&=r[2]
                r=r[1]
                --fill all the beings' personal registers with copy of r
                p=FillBeingRegs(p,r)
                --allow all beings to do all their operations
                p=Animate(p)
                p=RecordAnswer(p,i)
            end for

            --calculate the average answer
            p=AssessResults(p,answers)
            best=p[1]
            p=p[2]
			freeride=floor(MAXRUN/2)
            if mainCnt>freeride then
                minPerformance=1/mainCnt*MINPERF
            end if

            if mainCnt=1 then
				msg={"","","Running...",""}
				msg=append(msg,formula)
                MainBox(msg,BRIGHT_GREEN)
            end if
            
			--report
            msg=""
            msg=append(msg,sprintf("Math Beings working on formula    : %s",{formula}))
            msg=append(msg,sprintf("Number of try-sets per run        : %d",MAXRUN))
            msg=append(msg,sprintf("Number of runs this session       : %d",runs))
            msg=append(msg,sprintf("Number of tries per try-set       : %d",ANSLEN))
            msg=append(msg,sprintf("This is try-set number            : %d",mainCnt))
            msg=append(msg,sprintf("Target value                      : %.4f",SMALLVAL))
            msg=append(msg,sprintf("Current closeness (percent)       : %.6f",best))
            msg=append(msg,"")
            --MsgBox(sprintf("Completes:%d ",completes)&sprintf(" Runs:%d ",runs)& "<V>ery fast <F>ast <S>low ESC=Exit",YELLOW)
            MsgBox(sprintf("Completes:%d ",completes)&
					sprintf("Runs:%d ",runs)&
					sprintf("Set:%d ",mainCnt)&
					sprintf("Target:%.4f / ",SMALLVAL)&
					sprintf("%.6f ",best)&
					" ESC=Exit",YELLOW)
            key=lower(get_key())
            if equal(key,ESC) then
                PauseBox("User exits...",BRIGHT_RED,100)
                --exit
                abort(1)
            end if

            --if avg diffs too great, continue
            if best>SMALLVAL then
                p=HardTimes(p)
            else
				--possible winner, test further
	            PauseBox("We have a CONTENDER...",YELLOW,150)
                p=HardTimes(p)
 		        answers={}
 	            for i=1 to ANSLEN do
	                --run the formula, return registers and the answer
	                r=RunFormula(formula, vars)
	                answers&=r[2]
	                r=r[1]
	                --fill all the beings' personal registers with copy of r
	                p=FillBeingRegs(p,r)
	                --allow all beings to do all their operations
	                p=Animate(p)
	                p=RecordAnswer(p,i)
	            end for

	            --calculate the average answer
	            p=AssessResults(p,answers)
	            best=p[1]
	            p=p[2]
	            if best>SMALLVAL then
		            PauseBox("The CONTENDER...FAILED",BRIGHT_RED,200)
	                p=HardTimes(p)
				else
		            PauseBox("The CONTENDER...SUCCEEDED!",YELLOW,200)
               		completes+=1
                	exit
				end if
            end if
        else
            --Create initial genes for the population
            runs+=1
            PauseBox("Rethinking this formula -- starting over...",YELLOW,200)
            if CONTINUOUSRUN then
                msg={"","",	"","Continuous run -- no screen report..."}
                MainBox(msg,BRIGHT_GREEN)
            else
                MainBox("",BRIGHT_GREEN)
            end if
            p=CreateGenes(p,vars)
            mainCnt=0
            minPerformance=1000
        end if
    end while

    --ReportMathBeings(p[1])
    s1=RegToString(p[1][ORIGREG])
    msg=append(msg,"Most successful being's original register values:")
    msg=append(msg,sprintf("  %s",{s1}))
    msg=append(msg,"")
	
    --genes=p[1][GENE]
    --regs=p[1][STOREREG]
    genes=StripGenes(p[1][GENE],p[1][STOREREG])

    regs=genes[2]
    genes=genes[1]

    msg=append(msg,"")
    msg=append(msg,"Most successful being's genes:\n")

    for i=1 to length(genes) do
        gene=GeneToString(genes[i])
        s1=RegToString(regs[i])
        msg=append(msg,gene)
        msg=append(msg,"  "&s1)
    end for

    msg=append(msg,"")
    msg=append(msg,"Last actual answer from formula: "&sprintf("%.3f",answers[$]))
    MainBox(msg,BRIGHT_GREEN)

    if DEBUG then
        state=AppendFile(DEBUGFILE,msg,"GA Math Beings Report")
        CheckState(state,"DEBUG:File problem: AppendFile() failed on GA Report")
    end if

    if not CONTINUOUSRUN then
        key=ResponseBox("Run again? <Y>es  <N>o","YN",BRIGHT_WHITE)
        if equal(key,ESC) or equal(key,'N') then
            exit
        end if
    end if

end while

Goodbye()