TheGameCreators - CodeBase

Return to the CodeBase listing

Category: Miscellaneous

Version: 1.0

Information

Uploaded: 8th Jul 2004 08:40

Modified: 1st Jan 1970 01:00

Author: SandraD

Summary

HexaPawn game learning AI program

Full Description

This (my second complete) program plays the game of HexaPawn as described by J. D. Bagley for studying learning programs and their methods. See the help included, and source for details.<br />

DarkBASIC Source Code

` This code was downloaded from The Game Creators

` It is reproduced here with full permission

` http://www.thegamecreators.com

rem HexaPawn v1.0

rem converted to Dark Basic

rem 06/28/04 by SandraD

set display mode 640, 480, 32

sync on

sync rate 0

cls rgb(82, 44, 0)

dim b(10)

dim i(10)

dim m(10)

dim q(0)

dim v$(100)

dim d(100,9)

dim self(0)

dim games(3)

dim rate20(20)

dim rate50(50)

self(0) = 0

get_images()

rem *** Master Loop ***

restart:

if frst > 0 then frst = 0

for x = 1 to 10

b(x) = 0

i(x) = 0

m(i) = 0

next x

b(1) = 1

b(2) = 1

b(3) = 1

b(7) = 2

b(8) = 2

b(9) = 2

swapped = 0

draw_board()

draw_pieces()

titles()

last=0

lastv=0

rem *** Slave Loop ***

lp1:

f = 0

status()

sync

if escapekey() then end

rem commands...

input_test()

rem information...

if q(0) = 500

helper(0)

goto lp1

endif

rem database...

if q(0) = 400

exam()

titles()

goto lp1

endif

rem reset/restart

if q(0) = 300

for g = 1 to 100

v$(g) = ""

for h = 1 to 9

d(g, h) = 0

next h

next g

games(0) = 0

games(1) = 0

games(2) = 0

games(3) = 0

for h = 0 to 19

rate20(h) = 0

next h

for h = 0 to 49

rate50(h) = 0

next h

goto restart

endif

rem first move...

if q(0) = 200 and self(0) = 0

frst  = 1

goto doit

endif

rem set auto-play on/off....

if q(0) = 100 and self(0) = 0

self(0) = 1

goto doit

endif

if q(0) = 100 and self(0) = 1

self(0) = 0

goto restart

endif

rem invalid...

if (q(0) > 99 or q(0) = 0) and self(0) = 0

goto lp1

endif

rem human play...

doit:

if self(0) = 1

play(0)

else

if frst = 1

play(1)

titles()

frst = 2

goto lp1

else

if q(0) < 100 and q(0) > 10

frst = 2

c = int(q(0)/10)

d = q(0)-(c*10)

if b(d) = 2

draw_board()

draw_pieces()

goto lp1

endif

if b(d) = 1

b(d) = b(c)

b(c) = 0

hide sprite i(d)

i(d) = i(c)

i(c) = 0

endif

if b(d) = 0

b(d) = b(c)

b(c) = 0

i(d) = i(c)

i(c)=0

endif

rem computer play....

if b(1) = 2 or b(2) = 2 or b(3) = 2 then goto lose

play(1)

if b(0) = 0 then goto lose

lastv = b(10)

last = m(0)

if b(7) = 1 or b(8) = 1 or b(9) = 1 then goto win

swap_em()

b(0) = find_legal()

swap_em()

if b(0) = 0 then goto win

goto lp1

rem here we win...

win:

ink rgb(82, 44, 0), 0

sbox(0, 0, 200, 25)

ink rgb(255, 255, 255), 0

games(0) = games(0) + 1

games(1) = games(1) + 1

rate20(mod(games(0), 20)) = 1

rate50(mod(games(0), 50)) = 1

status()

if self(0) = 0 then dewait(11) else dewait(13)

goto restart

end

rem here we lost or had no legal moves...

lose:

c = int(last/10)

d = last-(c*10)

for x = 1 to 9

if (d(lastv, x) = last) or (d(lastv, x) = 0)

d(lastv, x) = last

goto bby

endif

next x

bby:

games(0) = games(0) + 1

games(2) = games(2) + 1

rate20(mod(games(0), 20)) = 0

rate50(mod(games(0), 50)) = 0

status()

if self(0) = 0 then dewait(10) else dewait(12)

goto restart

end

rem smart box -- x, y, wide & high...

function sbox(x, y, w, h)

box x, y, x+w, y+h

endfunction

rem modulo....

function mod(num,base)

hh = num-(int(num/base)*base)

endfunction hh

rem we grab the graphics here...

function get_images()

load bitmap "hexa.bmp"

get image 1,  0,  0,  52,  68

get image 2, 52,  0, 104,  68

get image 3,  0, 70,  70, 138

get image 4, 70, 70, 140, 138

get image 10, 0, 138, 166, 270

get image 11, 166, 138, 332, 270

get image 12, 0, 270, 166, 402

get image 13, 166, 270, 332, 402

cls rgb(82, 44, 0)

endfunction

function draw_board()

ink rgb(127, 127, 0), 0

sbox(55, 55, 220, 214)

paste image 3,  60,  60,1

paste image 4, 130,  60,1

paste image 3, 200,  60,1

paste image 4,  60, 128,1

paste image 3, 130, 128,1

paste image 4, 200, 128,1

paste image 3,  60, 196,1

paste image 4, 130, 196,1

paste image 3, 200, 196,1

endfunction

function draw_pieces()

a = 0

b = 3

for x = 0 to 9

i(x+1) = 0

d = int(x/3)

c = x-(d*3)

if b(x+1) = 1

a = a + 1

sprite a, 64+(c*72), 60+(d*68), 2

show sprite a

i(x+1) = a

endif

if b(x+1) = 2

b = b + 1

sprite b, 64+(c*72), 60+(d*68), 1

show sprite b

i(x+1) = b

endif

next x

endfunction

function titles()

ink rgb(82, 44, 0), 0

sbox(295, 90, 180, 250)

ink rgb(128, 175, 145), 0

set text font "Arial"

set text size 50

text 290, 25, "*** HexaPawn ***"

set text size 15

text 380, 65, "ed. 6.0 / v1.0 by SandraD 2004"

ink rgb(178, 175, 0), 0

set text size 22

text 295, 90, "Commands:"

ink rgb(82, 44, 0),0

sbox(315, 120, 300, 30)

ink rgb(178, 175, 0), 0

if self(0) = 0  then text 315, 120, "Self Play or Demo Mode"

if self(0) = 1 then text 315, 120, "Stop Demo Mode"

text 315, 150, "Make First Move"

text 315, 180, "Forget All/Reset"

text 315, 210, "Examine Data"

text 315, 240, "Instructions & Information"

endfunction

rem get inputs... what else?

function input_test()

q(0) = 0

if mouseclick()

a = mousex()

b = mousey()

rem This section deals with player pawn movement...

rem So it also checks for valid moves at the same time.

if a > 60 and a < 270 and b > 60 and b < 260

d = 3 * ((b - 60) / 68) + ((a - 60) / 70) + 1

if b(d) = 2

e = i(d)

f = sprite x(e)

g = sprite y(e)

while mouseclick()

sprite e, f+(mousex()-a), g+(mousey()-b), 1

sync

endwhile

a = mousex()

b = mousey()

c = 3 * ((b - 60) / 68) + ((a - 60) / 70) + 1

z = int((d-1)/3)

y = d-(z*3)-1

if c > 9 then c = d

if (c + 3) <> d and b(c) <> 1

sprite e, 64+(y*72), 60+(z*68), 1

goto exi

endif

if (c + 3) = d and b(c) <> 0

sprite e, 64+(y*72), 60+(z*68), 1

goto exi

endif

if (d - c) <> 3

q(0) = d * 10 + c

goto exi

else

z = int((c-1)/3)

y = c-(z*3)-1

sprite e, 64+(y*72), 60+(z*68), 1

q(0) = d * 10 + c

goto exi

endif

rem This section handles the commands list...

if a => 315 and b => 120

set text size 22

ink rgb(245, 245, 0), 0

while mouseclick() = 1

if b > 120 and b < 150

q(0) = 100

ink rgb(82, 44, 0),0

sbox(315, 120, 300, 30)

ink rgb(245, 245, 0), 0

if self(0) = 0 then text 315, 120, "Self Play or Demo Mode"

if self(0) = 1 then text 315, 120, "Stop Demo Mode"

endif

if b > 150 and b < 180

q(0) = 200

text 315, 150, "Make First Move"

endif

if b > 180 and b < 210

q(0) = 300

text 315, 180, "Forget All/Reset"

endif

if b > 210 and b < 240

q(0) = 400

text 315, 210, "Examine Data"

endif

if b > 240 and b < 270

q(0) = 500

text 315, 240, "Instructions & Information"

endif

sync

endwhile

endif

exi:

endfunction

rem print data

function status()

ink rgb(82, 44, 0),0

sbox(45, 295, 570, 90)

ink rgb(250, 250, 250), rgb(82, 44, 0)

text 50, 300, "Games Played: "+str$(games(0))

text 250, 300, "Won: "+str$(games(1))

text 350, 300, "Lost: "+str$(games(2))

text 450, 300, "Memory: "+str$(games(3))

if games(0)

z = (games(1)*100)/games(0)

ink rgb(230, 44, 0),0

text 200, 340, "<<<<Success Rates>>>>"

line 75, 359, 540, 359

text 80, 360, "Total="+str$(z)+"%"

h = 0

for x = 0 to 19

h = h + rate20(x)

next x

z = (h*100)/20

text 230, 360, "20 games="+str$(z)+"%"

h = 0

for x = 0 to 49

h = h + rate50(x)

next x

z = (h*100)/50

text 400, 360, "50 games="+str$(z)+"%"

endif

endfunction

rem Who says you need a HUGE matrix

rem for a fading scrolly?

function helper(num)

dim g$(7)

dim ay(7)

if num = 0 then restore my_stuff

if num = 1 then restore help1

for yy = 1 to 7

read tm$

g$(yy) = tm$

ay(yy) = 450 + (yy * 30)

next yy

tt = 1

set text size 25

set text opaque

repeat

for yy = 1 to 7

if ay(yy) < 300

ay(yy) = 510

read tm$

g$(yy) = tm$

if tm$ = "zz" then tt = 0

else

if ay(yy) < 326

aa = ay(yy) - 300

cg = (163 * aa) / 25

hg = (201 * aa) / 25

else

cg = 163

hg = 201

endif

ink rgb(cg+82, hg+44, 0), rgb(82, 44, 0)

text 50, ay(yy), g$(yy)

ay(yy) = ay(yy) - 1

ink rgb(82, 44, 0), rgb(82, 44, 0)

line 0, ay(yy), 640, ay(yy)

endif

next yy

wait 1

sync

until tt = 0

set text transparent

undim ay(14)

undim g$(14)

titles()

my_stuff:

data "HexaPawn is a board game first proposed by J. D."

data "Bagley, for the purpose of studying how learning"

data "algorithms and experiential databases may be"

data "applied to computerized tasks."

data ""

data "This program models that process, by understanding"

data "the rules of the game as defined when first begun,"

data "then using its experience at playing the game as a"

data "guide to which moves are better for a given situation"

data "than others."

data ""

data "To do this the program remembers when it has lost a"

data "game and what move caused that outcome, not making"

data "that same choice a second time when in the same"

data "situation."

data ""

data "Though it is always possible beat the program by"

data "electing that it make the first move, winning becomes"

data "increasingly difficult as the program learns and you"

data "start play."

data ""

data "Of particular concern to researchers is finding the"

data "minimum number of games needed to give the program"

data "the greatest success rate, which this version does"

data "not consider or utilitize."

data ""

data "The rules of HexaPawn are simple;"

data "   1) A piece may move forward to an empty square."

data ""

data "   2) A piece may capture an opposing piece diagonally."

data ""

data "   3) To win, one of the following must occur;"

data ""

data "       a) A pawn reaches the far side of the board,"

data ""

data "       b) All opposing pieces are captured,"

data ""

data "       c) or, No legal move remains after an action."

data ""

data "Enjoy!"

data ""

data "Genealogy (as known)"

data "Original Concept: J. D. Bagley, 1967, Univ. of Mich."

data "Paper Instructional Model: *unknown*, 1969."

data "Super Basic implementation: Mary Bell 1970"

data "MS Basic port: 1978"

data "GW port: 1992"

data "C++ port: Nak, 1998."

data "Dark Basic port: SandraD 2004"

data "-- end --"

data ""

data "zz"

help1:

data "The Data Collection List is three columns wide,"

data "the first entry being the situation number in the"

data "order the program encountered it."

data ""

data "In column two a representation of the board is"

data "shown, black pieces appearing as 1 and white as 2."

data "If this column is blank, no entry has been added."

data ""

data "Column three are those moves confirmed as losing"

data "options, each 10's digit value being a from point"

data "on the board and the 1's digit the destination of"

data "a given piece. Squares are numbered as;"

data ""

data "1 2 3"

data "4 5 6     example 14 == from square 1 to number 4"

data "7 8 9"

data ""

data "--end of help--"

data ""

data "zz"

endfunction

rem this works out possible moves for the computer

rem on exit, M() contains moves for all pieces.

rem and the function returns the number of values in

rem in the M() array.

function find_legal()

for x = 1 to 9

m(x) = 0

next x

q3 = 0 : rem count of moves possible...

for q1 = 1 to 6

if b(q1) <> 1 then goto skip

if b(q1+3) = 0

q3 = q3+1

m(q3) = q1*11+3

endif

if (b(q1+2) = 2) and (q1 = 2 or q1 = 3 or q1=5 or q1=6)

q3 = q3+1

m(q3) = q1*11+2

endif

if (b(q1+4) = 2) and (q1 = 1 or q1=2 or q1=4 or q1=5)

q3 = q3+1

m(q3) = q1*11+4

endif

skip:

next q1

digest()

endfunction q3

rem this digests the board for the history file

rem turning it into a string can check easily.

function digest()

v$(0) = ""

for v1 = 1 to 9

v$(0) = v$(0) + right$(str$(b(v1)),1)

next v1

endfunction

rem swap the sides of the board...

rem for self-play or demo mode.

function swap_em()

for x = 0 to 3

y = b(1 + x)

z = b(9 - x)

if y > 0

if y = 1 then y = 2 else y = 1

endif

if z > 0

if z = 1 then z = 2 else z = 1

endif

b(9 - x) = y

b(1 + x) = z

next x

if b(5) > 0

if b(5) = 1 then b(5) = 2 else b(5) = 1

endif

endfunction

rem here's where we check the history

rem file to see if we've had this problem

rem before. Value returned is offset into

rem the arrays.

function seen_it()

for v1 = 1 to 100

if v$(v1)=v$(0)

goto found

else

if v$(v1) = ""

v$(v1) = v$(0)

games(3) = v1

goto found

endif

next v1

ink rgb(255, 255, 255), 0

text 0, 0, "Out of storage space!"

break

found:

endfunction v1

rem choose a move from the available

rem removing those we know are losers.

rem value returned is move or zero

function pick_one(v1)

m(10) = m(0)

m(0) = 0

for q1 = 1 to 9

for q2 = 1 to 9

if m(q2) = d(v1,q1) then m(q2) = 0

next q2

next q1

q3 = 0

for c = 1 to 9

if m(c) <> 0 then q3 = q3 + 1

next c

if q3 = 0 then goto no_move

got_move:

c = int(rnd(8)+1)

if m(c) = 0 then goto got_move

m(0) = m(c)

no_move:

endfunction q3

rem this function animates moves

rem made by the program...

function ani_move(g)

if g > 96 then goto bbye

c = int(g/10) : rem from

d = g - (c*10) : rem dest

e = i(c)

if e = 0 then goto bbye

f = b(c)

b(c) = 0

i(c) = 0

g = sprite image(e)

c = c - 1

m = int(c/3)

n = c-(m*3)

x1 = 64+(n*72)

y1 = 60+(m*68)

d = d - 1

m = int(d/3)

n = d-(m*3)

x2 = 64+(n*72)

y2 = 60+(m*68)

x3 = (x2-x1)/30

y3 = (y2-y1)/30

for z = 1 to 30

sprite e, x1, y1, g

x1 = x1 + x3

y1 = y1 + y3

if mouseclick() then goto ani2

sync

next z

ani2:

sprite e, x2, y2, g

if b(d+1) <> 0 then hide sprite i(d+1)

b(d+1) = f

i(d+1) = e

bbye:

endfunction

rem smart wait with sprite...

function dewait(num)

sprite 10, 85, 90, num

show sprite 10

for x = 1 to 90

wait 5

if mouseclick() then goto dew1

next x

dew1:

hide sprite 10

endfunction

rem shift move values around center

function rotate()

c = int(m(0)/10)

d = m(0)-(c*10)

c = 10 - c

d = 10 - d

m(0) = c * 10 + d

endfunction

rem let us look at the data

function exam()

z = 1

loopa:

ink 0, 0

sbox(295, 90, 180, 250)

ink rgb(255, 255, 255),0

for x = 0 to 3

y = 95 + (x * 60)

set cursor 300, y

print z+x

set cursor 340, y

for g = 1 to 9

print mid$(v$(z+x),g);" ";

if g = (int(g/3)*3) then set cursor 340, y+g*4

next g

set cursor 400, y

for g = 1 to 9

print d(z+x,g);" ";

if g = (int(g/3)*3) then set cursor 400, y+g*4

next g

next x

set cursor 300, 320

print "+ = next  - = prev  H = help"

sync

if inkey$() = "" then goto loopa

if inkey$()="+"

z = z + 3

if z > 97 then z = 97

loopb:

if inkey$()="+" then goto loopb

goto loopa

endif

if inkey$()="-"

z = z - 3

if z < 1 then z = 1

loopc:

if inkey$()="-" then goto loopc

goto loopa

endif

if inkey$()="h" or inkey$() = "H"

helper(1)

loopd:

if inkey$()="h" or inkey$() = "H" then goto loopd

status()

goto loopa

endif

endfunction

rem make a move

function play(swap)

f = 1

do_it:

if swap = 0 then swap_em()

b(0) = find_legal()

if swap = 0 then swap_em()

if swap = 0 or f = 0

b = pick_one(0)

else

b(10) = seen_it()

f = pick_one(b(10))

if f = 0 then goto do_it

endif

if m(0)

if swap = 0 then rotate()

ani_move(m(0))

if swap = 0 then rotate()

endif

endfunction

Download

Please login to download

Comments

No comments yet.

CodeBase - HexaPawn

Information

Summary

Full Description

DarkBASIC Source Code

Download

Screen Shot

Author

Comments

Author Name:	SandraD
CodeBase Entries:	4