-- PS Programmieren I
-- Freie Problemformulierung:
-- Connect 4 mit Computer AI
-- last modified: 12.01.1999
-- written Peter PALFRADER 9717642 (mailto:palfrader@writeme.com)
-- copyright: contact palfrader@writeme.com for infos
-- known features(bugs):
-- if the map is to large(e.g. 388*4; 153*8) the program SEG FAULTs after/when calling InitThreadMap
-- Although in the original game the two players have the colors red and yellow and it is not
-- particulary stated who will start, I use in this program the two "names" white and black
-- where white is always the one to start the game.
with ada.text_io;
use ada.text_io;
with ada.integer_text_io;
use ada.integer_text_io;
with ada.io_exceptions;
use ada.io_exceptions;
procedure bsp19 is
type Tsquarestatus is (empty, white, black);
type TPlayerIs is (human, computer);
type TPlayersAre is array(white..black) of TPlayerIs;
function get_one_input(prompt : string) return positive is
f : integer:=-1;
begin
while (f<1) loop
begin
put(prompt);
get(f,9);
Skip_line;
exception
when ada.IO_EXCEPTIONS.DATA_ERROR =>
Skip_line;
end;
end loop;
return(f);
end;
procedure connect4(
COLS : in positive;
ROWS : in positive;
PlayersAre : in TPlayersAre) is
VERBOSE : constant boolean := true; -- debugging
WHITE_USES_BOOK : boolean := false;
BLACK_USES_BOOK : boolean := true;
ExpCOLUMN_SHOULD_BE_OVER_FULL : exception;
ExpBOOK_SIZE_NOT_OK : exception;
MAXDEPTH_CONST : constant positive := 8;
adaptborder : constant positive := 100000;
first_adapted1 : boolean := true;
first_adapted2 : boolean := true;
MAXDEPTH1 : positive := MAXDEPTH_CONST;
MAXDEPTH2 : positive := MAXDEPTH_CONST; -- just in case both players are computers
tested : natural;
SOMETHING_VERY_HIGH : constant integer := 30_000; -- DO NOT USE INTEGER'FIRST 'LAST!!!!!
SOMETHING_VERY_LOW : constant integer := - SOMETHING_VERY_HIGH;
-- scince -integer'first=integer'first with gnat's Ada compiler !! :/
-- and integer'last+1 = integer'first (no range checking)!!
opponent : constant array(white..black) of Tsquarestatus := (black, white);
mensign : constant array(Tsquarestatus) of character := (' ', 'X', 'O');
type Tmap is array(1..COLS, 1..ROWS) of Tsquarestatus;
type Tplayable is array(1..COLS) of natural;
type TEvaluationResult is (ONE_HAS_WON, BOARD_FULL, GAME_NOT_OVER);
type TBestMoveResut is (UNDECIDED, PLAYER_WINS, PLAYER_LOOSES);
MAX_THREAD_COUNT : constant positive := COLS*(ROWS-4+1) -- All verticals
+ ROWS*(COLS-4+1) -- All horizontals
+ 2 * (ROWS-4+1)*(COLS-4+1); -- All diagonals
type TThreadArr is array(integer range <>) of positive; -- positive ~ pointer to score array()
type PThreadArr is access TThreadArr;
type TThreadMap is array(1..COLS,1..ROWS) of PThreadArr;
type Tscore is array(white..black, 1..MAX_THREAD_COUNT) of natural;
type TAbsScore is array(white..black) of natural;
WHITE_BOOK : constant string := "425-5-5-1-1-1-5-56-2-6-6-6-2-2-4303334333333343333333433344444544333353333333433333"&
"33233356-6-6-6-6-6-3333433344-4-4-4-566666664-4-44-4-4-4-566666634-4-3333353333333533333335333566666653333533325155"&
"5153333233333333433333334333333343335226222625555515333343333333433344-4-4-4-553633524-4-21-5-1-1-5-1-1-25-5-1-1-5-"&
"1-1-430343233344444544333343332141111133332333333323333333233344-4-4-4-533333334-4-33333433333334333333343335226222"&
"225155515333343333333433344-4-4-4-335333534-4-33333233333335333251555152121111133332333122222223333533321-444445441"&
"-1-1-1-1-21-333323331-1-1-1-1-21-5-1-5-1-1-5-546-2-6-2-6-2-2-42-6-6-6-2-2-2-46-6-6-6-6-6-55555554543134333555555455"&
"555553545555545333343335555556542-6-6-6-2-2-2-555-5-5-5-5-333333365-55-5-5-5-5-331333365-55-5-5-5-5-333333335-55-5-"&
"5-5-5-333314365-55-5-5-5-5-433336365-33333533333331333422322265223242443345343333343333333433355-5-5-5-5-633334345-"&
"42-2-6-2-6-2-2-42-2-5555555454313433355555545555555354555554533334333555555452-2-2-2-564-4-4-4-54033533343335333555"&
"55525555555355555554543324332555555354-4-46-6-6-6-6-6-55555554543134333555555455555553545555545333343335555556564-4"&
"-4-4-5555555255555552524443544555555355555554542624334555555254-4-64-4-4-4-3355553355355543353525433434244342344446"&
"544444244444446464-4-564033533343335333555555255555553555555545433243325555553555-5-5-5-5-333333335-655555525555555"&
"25244435443352543355555545426243345555552555-5-5-5-5-363624325-55-5-5-5-5-463666465-4633243323223222662624334464632"&
"4432262226322622263666222233333233333334333333343334266226233335333333343333333233364-4-4-4-44445354444453544455235"&
"45344432542432345452343222444535444-4-555-5-5-5-5-444434465-4555555454313433355555545555555354555554533334333555555"&
"6555-5-5-5-5-222232225-55-5-5-5-5-344222265-33333233333334333333343334226222233335333333343333333233333333433343334"&
"333333323333226646233334333633234533333533355-5-5-5-5-644434445-3333-3-3-4056_2223-3-3-33-3-3-5444_5443-3-3-33-3-3-"&
"2212_2263-3-3-42555151156262262655555556555_55525555111566662642155551533-3-3-2224_2223-3-3-33-3-3-0500_4003-3-3-33"&
"-3-3-4224_2223-3-3-333-3-3-5444_5443-3-3-33-3-3-6414_6543-3-3-33-3-3-1202_0003-3-3-15444454406466150010264510146_05"&
"101144454055555112204000033-3-3-4444_1443-3-3-13333533305355333055255110555551105355543033114535300003033-3-3-6662_"&
"6613-3-3-333-3-3-2212_2263-3-3-33-3-3-1202_0003-3-3-33-3-3-6422_4543-3-3-64555555545555555455555554555_555555552455"&
"21210554555555533-3-3-2222_0203-3-3-33-3-3-2225_2223-3-3-33-3-3-4444_2443-3-3-324551551554444144415151114151_515441"&
"44444551255554155111111042210415565454124242241244_15411021451521511514111145156444444464444444644444446444_4444662"&
"6464644444445555525542555_1155666_6622224_422_2155_1111222_2222551_51111114111102222222220200000222_222022222220222"&
"22220222222255215222212151151551254655255_22452542424521210115265442642155111111111451222222522155_1112151511112252"&
"22225511511333-3-3-2224_2223-3-3-33-3-3-4444_1443-3-3-33-3-3-2222_0203-3-3-02111111111150454112411112111_1112111111"&
"1211111112111111133-3-3-0212_4423-3-3-56513546661511411621214326512046546666663661364333333433333-3-3-4044_4543-3-3"&
"-333-3-3-0500_4003-3-3-13333533305355333055255110555551105355543033114535300003033-3-3-2225_2223-3-3-54666626465511"&
"111661222556512_00565100465661512211221222233-3-3-5666_4643-3-3-33-3-3-0210_2523-3-3-33-3-3-1221_2223-3-3-333-3-3-2"&
"444_2143-3-3-33-3-3-6662_6613-3-3-33-3-3-4444_2443-3-3-24551551112040000415555150111_11101111111144040004551551533-"&
"3-3-4044_4543-3-3-33-3-3-1221_2223-3-3-33-3-3-2444_0163-3-3-";
BLACK_BOOK : constant string := "3004_522232154234502222333236153433344343443412345131526416313123333113333332132334"&
"0301234300434144413121451053214562220234522022315023103030322232320332343452323053032234333335204561311303122223232"&
"3412605045123044533233533310035304332333334341444233234343310305043323456344234544312643630452345513121451204233503"&
"3323450455355435052355014323456305126463531234562002030006123436461304566052535560023406301313033311333333213233401"&
"0131411411210515152346653123456120143223126234102336233330323431421234561141345111213416201323340133123332010130011"&
"0000003333133313000400130000003031264061462341120111111031104314012045000123451001111164103211561012345621511151114"&
"2114440123150542233361632142650152346615523426203014343012044644226336601634666012346510312631303324313333323330142"&
"6336463214660112345661020406023013245231111111033333333200101003333333533033300333333333333233312133222233223133112"&
"1221211111113333233333332333220163422021232522500340032123230422234325202345034322323302223252131233502213323036122"&
"2564432344453323350303204204233333333212323322223432343234444332343352323433663233365233033301232323222023456333236"&
"5342323433521234203233632220333333331311111033030003021123260333430301033553010035630334504331311343122223232361200"&
"5045123044531233500230343616015335510503011333223533011005140143344351555336213333320222323220223433322323223222225"&
"222223432302212232232343135046444510160051001222534256_252001200565510005042122252440345335151433444434333235144444"&
"3443444443333343403434345033233533633665036336652331000533633633350323350551535253333303331033043620221221425222124"&
"5445446531243366062645134031334561032115633332333300304540443005450425546601366564103211561211345621511151301204514"&
"1123155542255361632142633-3-3-301244533-3-3-40332005330123451221422544412335643333333555255263402645633-3-3-3414444"&
"43-3-3-450425556542263362515555555625526553255365333414333335333460136656163214262313435330026456405335663333533366"&
"6364563004423455013234512042335030023450451355535052355006523456103121451031203513333233301026453453211335102045001"&
"02345620042335013000400200134563012545545555555500231505012543030002345000123451201254513002_4564555545550523405001"&
"2645645042554615324136251555555552552655525536533346435662666350052345050123415200231503052345143334143501234165052"&
"3545013123143111234562010335530126456456354565512345661123455300652645653123456200203036332345346133456605253556062"&
"3466103136313033243033333233301426336463214360112345633333333200120303130000002001335630120466431323535042543000100"&
"3563016264065012345620120412061224364402645603126456603204664601366561632146623132353340264564053306656626663636364"&
"5660052535550123465532334325033042533334333505234565352543333-3-3-341666563-3-3-22001123465122022332111352531123425"&
"5012344540123454521235361222222222222222223003435321234255412344432132152641235360201036651222346511023200311111111"&
"1003465110036041100354130112342512123425201014451100040022212222444440442221222241041322212223525112131653111111112"&
"2132656551311555123515400123454121224542015341534444044401234545412315441153555502123531141034542313141330121422451"&
"235111333343343333333105512345111523465220234003212346541123465611234525112345610522346556_534552222342231223465422"&
"2346560523455505534562022234002221341521113455313244654022346560223456502234263116234651662346521324465323234654212"&
"3465621234525512345640212346512223465202254653212346540123165601234525215345260512345210653455601234523512345240123"&
"4555015325522113152505123456105534565015356532123452421234525413345224103466211002140021213433210134333222346542223"&
"463612234563122143610222340022213415211134553132446540225465506264535022342620011646511113455501_346533335465401554"&
"6360651416501534663112234653113333323335465311655654112646562123452511234664222354351022346520155463521234224212516"&
"5611224565222242661122345512223455206514153112345241122455525234555012346552313243612223426203534663212345642222426"&
"2323245561123442320112342512113625201014451100000022212222444440442221222211102346512023465213244653012346542123465"&
"6512345552123456333330333211333333333233332212644333323333333233343133232320125261121234652116556555525515525254546"&
"2125552521254524211111111512346521126465321232652111111162552252525222126201214541212345222123452321255524255225252"&
"1232552411142252012142215123456221234563212545242522212521232552211142641204132222422326522223463322222222221326562"&
"2232225222322210112346512223465202254653012346540123465601634555215345222225543510223465201164635212342242125465611"&
"2245652222426321111151161234652152646532123265211111516255225252522212411423265101236652212546532123265120231656152"&
"3156515231566255531111012345221122455325522524052315651123455522234655251235115616362222222426325222124152315652123"&
"4512115311662001234151212315220113151301214544551311150123451100034001021234551056345620523455321234554012345650113"&
"4512211315221122345510223455206614153112345240122455515234555012346532012145412123452211234523212555242552252521232"&
"5524111422264123455111234552115345534144414451235455414345451423445520123511161134552212345532123255401234515211346"&
"1521234162100035002222222210123456341114224151311110252456652134555202123435141234542313141330121422544434441333343"&
"3433333331011234561055345655253465321234524215345254133452241034662122234261252342620153456321234664222242623332456"&
"6112344232012142212123452221234563212545242522212521232552221142642512351156163622222224263252221241523156521134562"&
"1513116520123421141334522232345332123255421234515211322221113516243333333141634661356345632211426455131161336243663"&
"1534313200422333220223150231030303222323203323434304233500322343310312333033000000203333333512343434044004330004003"&
"3000000003333333311111112030343030323332301323433012345003303000302223232202232333223232232222262202234343022122222"&
"3232313333343333333133343144353421422534312343345555555431323533004233503333133320013456301254554555555550023150001"&
"0555530002030313000400200633663012045243134353500254300010035632013233411336233320101300110004003333133343434333130"&
"0000012336233312223422233213333222322223323443235234532325333323333233333332333233353331333343333333333111232513333"&
"633332011111112223222212112113212_222211214412112145121121111233331333133234434151111114444444333333333333433341111"&
"1112434343331352345310331453100114503333433310255454503524312130004001325233310311411104114314111115110332442102114"&
"2620303223230612345226003400321232304252345352123452222334361110234311232303301003421313333332303333231123251113034"&
"3620600345011113411601_34533033345340154456533334536616345632214343431311211301324113212225242243242501334522433345"&
"6423203422130034332036445632243242443034333252345533323453502023456133034512333345330133453423234555012345260123453"&
"2333333231121323633333343343334562224222232443256631334313202223232202234333223232232222262202234323022122322323231"&
"1114231511052323121333333301213563614443335120303333303002023334303131121330132411301224524224324250133252243334523"&
"0612225611121051201224526012_45544144644501263566016645622222343424233331332223333220224224333442443233342233323253"&
"3332352333223512013325330126456363262505322335222233251222323431232331333222232232222251221332325223325662263451233"&
"3334333333313334314435342142254431234334555555543134353333331333133234434151111114444444333333333333433341111151233"&
"3334433313343363333433343434444336343434343454233334333202234342423333133222333322022422433344232232522223332324331"&
"2343331123414233632343424324443122036144234444112364634515555533334333455555453444545443123433514234454515551563334"&
"4433331413342332343332223432433234143134345433433443320042335013000400200234553012545545155555500231505002543023333"&
"1333135234531033145110011450333343331025545410312442222143252111232512333345532155452222430525212345012123256320125"&
"45121121451221552513222_4524522545552223422211234562455555553333433345555545344254544312443351423444455555155200231"&
"5020111411221234523222342243223433522232212012345425042543010330442525354355255542545555515501234545015543632000203"&
"0013000400200133563012046243134353500224300010035623333133313252333103114311041143141111151103314421021142623333333"&
"333333333233333533111121633333333121234563333333323012045210411401322622226013335642144254551554253212636633-3-3-30"&
"1224563-3-3-6532334322011131553322433532234652134345452223456522354322001003561021142662166322631664333333433350155"&
"4366012331231004123545111535452112354534121545501234444042345460123546101153545106535455012345534341545501434544114"&
"3454501134564303311434142324133322333423222223133433324544414332323323041215451434154520125541103245455412145444121"&
"4545012145654052551510143454245444143012145440121454411235444152564644042554411143454245444143412145440023454541234"&
"5144425456500123456101134562022141530121456455254465012355660123456220112342512123625201014451100000022212222444440"&
"4422212222111523465160234652132446532323465411234656212345552123456333331333211333333333233332212544632333323333233"&
"3333323333201152611212346521125565525255155252545462125552521254524211111511212346521126465321232652111111162552252"&
"5252221262012145415123452221234523212555224144414521232552411142252012142212123452221234563212545242522212521232552"&
"2211426413033114341423241333223334232222231334333245444143123233204214212533123333332223334212222333333433425222524"&
"5143222313322333032223332103433321032133333313333333133333331333412322222021222232102345121103050211300505222222202"&
"3224463133343330333333333331333142223333333433333334333033333322145444140414411445155555310434544102045551023454455"&
"5555504252324245143222333233334332244633333332442245523433323631041215451434154520125541103245455412145444121454501"&
"2145622011526112323465211655655552555552525454621255525212545212012554114321545221515451222254252121454421214145212"&
"545611032454511511541555251151442_545511114144111141415525546514121454225254541212145454214444412151545121543245211"&
"4564141214540411145412121414111114114101145551023434450415565101214562212545212125456562124364521145651215232612154"&
"5226303433342411244236333433202244343333343324443251242444144211111511212346521126465321232652111111162552252525222"&
"1233333433363233333333323335333444233335333633333335333233326022443410444444461663554616365546123465654444545444443"&
"4333335333333353333333533343354365433623656333444353334433624443251241444143333333323444454333344433333345321454254"&
"5343343454252221233332333244444343333443325243425332353364140425544111434542454441434121454401234545012345444425656"&
"0444255521114345442522252341114544412345551123454421254562145444140414411445555555310434544102045551023454455555553"&
"1412145404111454121214141111141441011455510234544504145632434335333334333043333433220454433334333433333553333633351"&
"4123451041234512102345531023454410224355102346451023465444444544222622224444454456666665410256565142345461423455510"&
"0123456101134562022141130121456455254465012315660123456220121422151234522212346632125452425222125212325522211426120"&
"2214112221345522125456321254564252221252123256255114163101214562212545212125456562124364521145651215232612154522343"&
"3434542522212333323332444443433334433252434253525533651012345622123255121232563121523216123456512131066121315560121"&
"3456221234261222342631215452412134555121315561213451-"; -- last - added
BOOK_DEPTH : constant positive := 5;
type TDicArr;
type PDicArr is access TDicArr;
type TDicMove is record
answer : integer;
followups : PDicArr;
end record;
type TDicArr is array(1..7) of TDicMove;
COLUMN_SHOULD_BE_FULL : constant integer := -1;
black_root : PDicArr := null;
white_root : PDicArr := null;
WHITE_FIRST : positive := 4;
droporder : Tplayable;
Map : TMap;
playable : Tplayable;
ThreadMap : TThreadMap;
procedure updatescore_gamestatus(
score : in out Tscore;
absscore : in out TAbsScore;
gamestatus : out TEvaluationResult;
c,
square_played : in positive;
player : in TSquarestatus) is
opp : TSquarestatus := opponent(player);
diffplayer : integer := 0;
diffopp : integer := 0;
tmp : natural;
begin
gamestatus := BOARD_FULL;
for t in threadmap(c,square_played).all'range loop
tmp := threadmap(c, square_played)(t);
diffplayer := diffplayer + score(player, tmp);
diffopp := diffopp + score(opp , tmp);
score(player, tmp) := score(player, tmp)*2;
if score(player, tmp) = 16 then
gamestatus := ONE_HAS_WON;
end if;
score(opp, tmp) := 0;
diffplayer := diffplayer - score(player, tmp);
end loop;
absscore(player) := absscore(player) - diffplayer;
absscore(opp ) := absscore(opp ) - diffopp;
if gamestatus/=ONE_HAS_WON then
for c in 1..COLS loop
if map(c,ROWS) = empty then
gamestatus := GAME_NOT_OVER;
end if;
end loop;
end if;
end;
function evaluate(
player : in Tsquarestatus;
absscore : in TAbsScore) return integer is
begin
return absscore(player) - absscore(opponent(player));
end;
procedure BestMove(
player : in Tsquarestatus;
depth : in natural;
org_score : in TScore;
org_absscore: in TAbsScore;
alpha : in integer;
beta : in integer;
best_col : out natural;
best_result : out TBestMoveResut;
best_value : out integer) is
square_played : natural;
value : integer := SOMETHING_VERY_LOW;
best_ab : integer := alpha;
turns_2_loss : integer := -1;
opponent_move_col : integer; -- this one's a dummy;
opponent_move_result : TBestMoveResut;
score : TScore;
absscore : TAbsScore;
evaluation_result : TEvaluationResult;
c : positive;
begin
-- initializing out parameters
best_result := PLAYER_LOOSES;
best_value := SOMETHING_VERY_LOW;
for cloop in 1..COLS loop
c := droporder(cloop);
if playable(c) <= ROWS then -- column is not full
score := org_score;
absscore := org_absscore;
tested:=tested+1;
-- do the move
square_played := playable(c);
map(c, square_played) := player;
playable(c) := square_played + 1;
updatescore_gamestatus(score, absscore, evaluation_result, c, square_played, player);
case evaluation_result is
when ONE_HAS_WON => -- must be me :)
best_col := c;
best_result := PLAYER_WINS;
best_value := 0;
-- Undo the move and exit the loop; we won, what do we want more?
map(c, square_played) := empty;
playable(c) := square_played;
exit;
when BOARD_FULL =>
best_col := c;
best_result := UNDECIDED;
best_value := 0;
-- Undo the move and exit the loop; since the board is full, this is the only playable square
map(c, square_played) := empty;
playable(c) := square_played;
exit;
when GAME_NOT_OVER => -- I don't like this one ;)
if depth /= 0 then
BestMove( opponent(player),
depth-1,
score,
absscore,
-beta,
-best_ab,
opponent_move_col, -- this one's a dummy
opponent_move_result,
value);
case opponent_move_result is
when PLAYER_LOOSES => -- good for me :)
best_result := PLAYER_WINS;
best_col := c;
best_value := value+1; -- turns to win/loss
-- Undo the move and exit the loop; we won, what do we want more?
map(c, square_played) := empty;
playable(c) := square_played;
exit;
when UNDECIDED =>
value := -value; -- what's good for him is bad for me and vice versa
if value>=beta then -- YES, cutoff!!!
-- Undo the move
map(c, square_played) := empty;
playable(c) := square_played;
best_result := PLAYER_WINS; -- so this won't be taken (hopefully)
best_col := 0;
exit;
end if;
if (best_result = PLAYER_LOOSES) or else
( (best_result = UNDECIDED) and then (value > best_value) ) then
best_result := UNDECIDED;
best_col := c;
best_value := value;
if value>best_ab then
best_ab:=value;
end if;
end if;
when PLAYER_WINS => -- not good for me ;(
if (best_result = PLAYER_LOOSES) and then
(turns_2_loss < value+1) then -- the longer it takes the better
best_col := c;
turns_2_loss := value+1;
end if;
end case;
else
value := evaluate(player, absscore);
if value >= best_value then
best_col := c;
best_result := UNDECIDED;
best_value := value;
end if;
end if;
end case;
-- Undo the move
map(c, square_played) := empty;
playable(c) := square_played;
end if;
end loop;
if best_result = PLAYER_LOOSES then
best_value := turns_2_loss;
end if;
end;
procedure initmap is
begin
for c in 1..COLS loop
for r in 1..ROWS loop
map(c,r) := empty;
end loop;
playable(c):=1;
end loop;
end;
procedure drawmap is
begin
new_line;
for c in 1..COLS loop
put("---");
end loop;
new_line;
for c in 1..COLS loop
if c<10 then
put(" "); put(c,0); put(" ");
else
put(c,2); put(" ");
end if;
end loop;
new_line;
for c in 1..COLS loop
put("---");
end loop;
new_line;
for r in reverse 1..ROWS loop
for c in 1..COLS loop
put(" "); put(mensign(map(c,r)));put(" ");
end loop;
new_line;
end loop;
for c in 1..COLS loop
put("===");
end loop;
new_line(2);
end;
function gethumanmove(player : in Tsquarestatus) return positive is
result : integer;
validmove : boolean := false;
begin
while not validmove loop
result:=get_one_input(": ");
if result>COLS then
put("Not a valid move! Board consists only of "); put(COLS, 0); put_line(" columns.");
put("You play column");
elsif playable(result)>ROWS then
put_line("Not a valid move! Column full!");
put("You play column");
else
validmove:=true;
end if;
end loop;
return result;
end;
function getcomputermove(
player : in Tsquarestatus;
score : in tscore;
absscore : in tabsscore;
prevmove : in natural) return positive is
BestMoveResut : TBestMoveResut;
dummy : integer;
result : positive;
maxdeep : positive;
begin
tested:=0;
if player=white and then white_root/=null then
if prevmove = 0 then
result:=WHITE_FIRST;
if VERBOSE then put_line("white playing 1st move"); end if;
else
if white_root(prevmove).answer=COLUMN_SHOULD_BE_FULL then raise ExpCOLUMN_SHOULD_BE_OVER_FULL; end if;
result:=white_root(prevmove).answer;
white_root:=white_root(prevmove).followups;
end if;
put(result,0);put_line("."); -- Display the column played
if VERBOSE then put_line("Took Dictonary"); end if;
return result;
end if;
if player=black and then black_root/=null then
if black_root(prevmove).answer=COLUMN_SHOULD_BE_FULL then raise ExpCOLUMN_SHOULD_BE_OVER_FULL; end if;
result:=black_root(prevmove).answer;
black_root:=black_root(prevmove).followups;
put(result,0);put_line("."); -- Display the column played
if VERBOSE then put_line("Took Dictonary"); end if;
return result;
end if;
if (player=black) and then -- if both players are computers then each has his own adapted search depth
(playersare(white)=computer) and then
(playersare(black)=computer) then
maxdeep:=MAXDEPTH2;
else
maxdeep:=MAXDEPTH1;
end if;
BestMove( player,
maxdeep,
score,
absscore,
SOMETHING_VERY_LOW,
SOMETHING_VERY_HIGH, -- -(a very bad move)
result,
BestMoveResut,
dummy);
put(result,0);put_line("."); -- Display the column played
if VERBOSE then
put(tested, 0); put_line(" positions tested.");
end if;
-- adapt maxdepth
if tested<adaptborder then
if (player=black) and then -- if both players are computers then each has his own adapted search depth
(playersare(white)=computer) and then
(playersare(black)=computer) then
if not first_adapted2 then
MAXDEPTH2:=MAXDEPTH2+2;
if VERBOSE then
put("adapting depth +2 to "); put(MAXDEPTH2, 0); new_line;
end if;
end if;
first_adapted2:=false;
else
if not first_adapted1 then
MAXDEPTH1:=MAXDEPTH1+2;
if VERBOSE then
put("adapting depth +2 to "); put(MAXDEPTH1, 0); new_line;
end if;
end if;
first_adapted1:=false;
end if;
end if;
case BestMoveResut is
when PLAYER_WINS =>
new_line;
put_line("I'm going to win!");
when UNDECIDED => null;
when PLAYER_LOOSES =>
if VERBOSE then
put_line("Behind you, a three-headed monkey!!"); -- Display loss only in debug mode
end if;
end case;
return result;
end;
function Getmove(
player : in TSquareStatus;
score : in TScore;
absscore : in TAbsScore;
prevmove : in natural) return natural is
begin
if playersare(player) = human then
return GetHumanMove(player);
else
return GetComputerMove(player, score, absscore, prevmove);
end if;
end;
procedure Game is
score : TScore := (others => (others=> 1));
absscore : TAbsScore := (others => MAX_THREAD_COUNT);
gamestatus : TEvaluationResult;
active_player : TSquareStatus := white;
prevmove : natural := 0;
function PlayerIsImage(playeris : TPlayerIs) return string is
begin
if playeris=human then return "Human";
else return "Computer"; end if;
end;
function domove(
player : in Tsquarestatus;
c : in positive) return TEvaluationResult is
result : TEvaluationResult;
begin
map(c,playable(c)) := player;
updatescore_gamestatus(score, absscore, result, c, playable(c), player);
playable(c) := playable(c) + 1;
return result;
end;
begin
initmap;
drawmap;
loop
put("Player "&mensign(active_player)&" ("&PlayerIsImage(playersare(active_player))&") plays column ");
prevmove:=getmove(active_player, score, absscore, prevmove);
gamestatus := domove(active_player, prevmove);
drawmap;
exit when gamestatus /= GAME_NOT_OVER;
active_player:=opponent(active_player);
end loop;
if gamestatus = BOARD_FULL then
put_line("It's a draw!");
else
put_line("Player "&mensign(active_player)&" ("&PlayerIsImage(playersare(active_player))&") won!");
end if;
end;
procedure InitThreadMap is
tmp_threadmap : array(1..COLS, 1..ROWS, 1..MAX_THREAD_COUNT) of boolean := (others => (others => (others => false)));
threadnr : natural := 1;
tmpthreadarr : TThreadArr(1..16);
begin
for c in 1..COLS loop
for r in 1..ROWS loop
for t in 1..MAX_THREAD_COUNT loop
tmp_ThreadMap(c,r,t) := false;
end loop;
end loop;
end loop;
-- Set the horizontal win positions
for c in 1..COLS-3 loop
for r in 1..ROWS loop
for i in 0..3 loop
tmp_ThreadMap(c+i,r,threadnr):=true;
end loop;
threadnr:=threadnr+1;
end loop;
end loop;
-- Set the vertical win positions
for c in 1..COLS loop
for r in 1..ROWS-3 loop
for i in 0..3 loop
tmp_ThreadMap(c,r+i,threadnr):=true;
end loop;
threadnr:=threadnr+1;
end loop;
end loop;
-- Set the forward diagonal win positions
for c in 1..COLS-3 loop
for r in 1..ROWS-3 loop
for i in 0..3 loop
tmp_ThreadMap(c+i,r+i,threadnr):=true;
end loop;
threadnr:=threadnr+1;
end loop;
end loop;
-- Set the backward diagonal win positions
for c in 1..COLS-3 loop
for r in 1..ROWS-3 loop
for i in 0..3 loop
tmp_ThreadMap(c+3-i,r+i,threadnr):=true;
end loop;
threadnr:=threadnr+1;
end loop;
end loop;
for c in 1..COLS loop
for r in 1..ROWS loop
threadnr := 0;
for t in 1..MAX_THREAD_COUNT loop
if tmp_threadmap(c,r,t) then
threadnr := threadnr + 1;
tmpthreadarr(threadnr):=t;
end if;
end loop;
threadmap(c,r) := new TThreadArr(1..threadnr);
threadmap(c,r).all := tmpthreadarr(1..threadnr);
end loop;
end loop;
end;
procedure initdroporder is
cnt : natural := COLS / 2 + 1;
begin
for c in 1..COLS loop
droporder(c) := cnt;
if c rem 2 = 0 then
cnt := cnt + c;
else
cnt := cnt - c;
end if;
end loop;
end;
procedure InitGameTree is
aktpos : integer;
procedure DoTree (
depth : positive;
Book : string;
active : PDicArr;
mirrored : boolean ) is
begin
for s in 1..7 loop
if book(aktpos)/='_' then
if mirrored then active(s).answer:=55-character'pos(Book(aktpos));
else active(s).answer:=character'pos(Book(aktpos))-47; end if;
aktpos:=aktpos+1;
if book(aktpos)/='-' then
if depth<BOOK_DEPTH then
active(s).followups:= new TDicArr;
DoTree(depth+1, book, active(s).followups, mirrored);
end if;
else
aktpos:=aktpos+1;
active(s).followups:= null;
end if;
else
aktpos:=aktpos+1;
active(s).answer:=COLUMN_SHOULD_BE_FULL;
active(s).followups:=null;
end if;
end loop;
end;
begin
if WHITE_USES_BOOK and then playersare(white) = computer then
if VERBOSE then put_line("White Tree building..."); end if;
white_root := new TDicArr;
aktpos:=1;
for s in 1..4 loop
white_root(s).answer:=character'pos(WHITE_BOOK(aktpos))-47; aktpos:=aktpos+1;
white_root(s).followups:= new TDicArr;
DoTree(2, WHITE_BOOK, white_root(s).followups, false);
end loop;
if aktpos-1/=WHITE_BOOK'last then raise ExpBOOK_SIZE_NOT_OK; end if;
if VERBOSE then put_line("2nd half..."); end if;
aktpos:=1;
for s in reverse 5..7 loop
white_root(s).answer:=55-character'pos(WHITE_BOOK(aktpos)); aktpos:=aktpos+1;
white_root(s).followups:= new TDicArr;
DoTree(2, WHITE_BOOK, white_root(s).followups, true);
end loop;
if VERBOSE then put_line("White Tree built"); end if;
end if;
if BLACK_USES_BOOK and then playersare(black) = computer then
if VERBOSE then put_line("Black Tree building..."); end if;
black_root := new TDicArr;
aktpos:=1;
for s in 1..4 loop
black_root(s).answer:=character'pos(BLACK_BOOK(aktpos))-47; aktpos:=aktpos+1;
black_root(s).followups:= new TDicArr;
DoTree(2, BLACK_BOOK, black_root(s).followups, false);
end loop;
if aktpos-1/=BLACK_BOOK'last then raise ExpBOOK_SIZE_NOT_OK; end if;
if VERBOSE then put_line("2nd half..."); end if;
aktpos:=1;
for s in reverse 5..7 loop
black_root(s).answer:=55-character'pos(BLACK_BOOK(aktpos)); aktpos:=aktpos+1;
black_root(s).followups:= new TDicArr;
DoTree(2, BLACK_BOOK, black_root(s).followups, true);
end loop;
if VERBOSE then put_line("Black Tree built"); end if;
end if;
end;
begin
if (COLS=7) and then (ROWS=6) then InitGameTree; end if;
InitThreadMap;
initdroporder;
game;
end;
COLS, ROWS, game : natural := 0;
begin
new_line(3);
put_line(" Weasel's Connect-Four");
put_line(" ===============================");
new_line(3);
put_line("Written 1998/1999. Please send bug reports to palfrader@writeme.com.");
new_line;
put_line("Have fun!");
new_line(3);
while COLS<4 loop
COLS:=get_one_input("Please enter the number of columns (>=4; std=7) : ");
end loop;
while ROWS<4 loop
ROWS:=get_one_input("Please enter the number of rows (>=4; std=6) : ");
end loop;
new_line(3);
put_line("Select one of the following games: ");
new_line;
put_line("1 ... Human vs. Human");
put_line("2 ... Human vs. Computer");
put_line("3 ... Computer vs. Human");
put_line("4 ... Computer vs. Computer");
while (game<1) or else (game>4) loop
game:=get_one_input(": ");
end loop;
new_line(5);
case game is
when 1 => Connect4(COLS,ROWS, (human, human));
when 2 => Connect4(COLS,ROWS, (human, computer));
when 3 => Connect4(COLS,ROWS, (computer, human));
when 4 => Connect4(COLS,ROWS, (computer, computer));
when others => null;
end case;
end;