home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d9xx
/
d916
/
wbrain.lha
/
WBrain
/
WBrain.e
< prev
next >
Wrap
Text File
|
1993-10-04
|
20KB
|
554 lines
/***************************************************************************
*** WBrain v1.0
***
*** Brain for the WorkBench. Based on Brain by Andre Wichmann.
*** WBrain takes no code from Brain, and is written entirely in Amiga_E.
***
*** Amiga_E is a programming language by Wouter van Oortmerssen which
*** produces very small, fast code, and is designed to simplify the
*** creation of user interfaces.
***
*** Brain v1.01 can be obtained from the Fred Fish PD disk #652.
*** I'm not exactly sure where I obtained Amiga_E, but you can contact
*** Wouter by mail:
*** Wouter van Oortmerssen
*** Levendaal 87
*** 2311 JG leiden
*** HOLLAND
*** or by EMail:
*** Wouter@alf.let.uva.nl
*** Wouter@mars.let.uva.nl
*** Oortmers@gene.fwi.uva.nl
***
*** You can contact me only through snailmail:
*** Sean Russell
*** Claude-Lorrain-Str 31
*** 81543 München
*** GERMANY
***
*** If you want to change this code, I suggest the first thing you
*** start with is the variable names. I tend to make local variable
*** names rather short and ambiguous, since my routines are usually
*** pretty short and it's not that hard to remember what the variables
*** stand for (for me).
***/
/***************************************************************************
*** Global Setup
***/
OPT OSVERSION=37 /* Only runs on WB2.x or greater */
ENUM NONE,ER_LIB,ER_WB,ER_VISUAL,ER_MENUS,ER_WIND,ER_CONTEXT,
ER_GADGET,ER_REQTOOLS /* Error codes */
ENUM G_SLIDER, G_UNDO, G_RETRY, G_NEW /* Gadget codes */
MODULE 'intuition/intuition', 'intuition/screens', 'gadtools',
'libraries/gadtools', 'intuition/gadgetclass', 'exec/nodes',
'ReqTools', 'libraries/reqtools'
CONST BASE=$F800, /* What all menu messages have in common */
MENU1=$0, MENU2=$1, MENU3=$2, /* For menus 1 - 3 */
ITEM1=$0, ITEM2=$20, ITEM3=$40, ITEM4=$60, ITEM5=$80 /* For items 1-5 */
CONST M_ABOUT=BASE OR MENU1 OR ITEM1, /* Here we set the values for the */
M_QUIT=BASE OR MENU1 OR ITEM2, /* various menu items to the values */
/* that are returned by Intuition. */
M_UNDO=BASE OR MENU2 OR ITEM1, /* Perhaps they are defined somewhere, */
M_RETRY=BASE OR MENU2 OR ITEM2, /* but I found them out by trial and */
M_NEW=BASE OR MENU2 OR ITEM3 /* error. */
CONST MAX=10, MIN=2 /* Used for maximum and minimum */
CONST DMAX=MAX*MAX /* In-between value; not used, but we */
/* can't define complex CONSTants */
CONST MAXUNDOS=DMAX+1 /* rows*columns+1; the max number of moves*/
OBJECT gy /* I didn't find a way to do multi-dimensional arrays */
y[MAX]:ARRAY /* in E, so we have to do some gymnastics if we want */
ENDOBJECT /* to simulate them. This would be an *excellent* */
/* thing to change if you know a better way to do it. */
DEF w=NIL : PTR TO window, /* We set these values initially to NIL*/
visual=NIL, /* so that if they don't get set we can*/
scr=NIL:PTR TO screen, /* capture the errors. */
menu, glist=NIL,g, /* For the gadgets. */
gx[MAX]:ARRAY OF gy, /* The grid. Like I said, I couldn't find
a way to use multi-dimensional arrays normally.
Yes, I've tried the standard x[n][n] and x[n,n] */
goalx[MAX]:ARRAY OF gy, /* The goal array */
moves[MAXUNDOS]:ARRAY OF CHAR, /* For the UNDO function */
rows=8, columns=8, /* start values for rows and columns.
Oh, I should point out that I defined these somewhat
dyslexicly; rows are actually the columns, and columns,
rows. Since I was consistant in my stupidity, it works. */
offx, offy, wflags, rflags, /* window offsets for x&y; someday I'll change
the window to a GIMMEZEROZERO and won't need these, but since
that's more a matter of programming conveniency (as opposed
to preformance), I'm not in a big hurry to do it. */
wx, wy, move=0, /* Row width and column height (after the buttons and borders)*/
basex, basey, level /* Minimum width and height; game level */
/******************************************************************************
*** PROC main
***/
PROC main()
Rnd(100) /* Version 1.1 will use the date/time to get a really random
starting grid */
wflags := IDCMP_CLOSEWINDOW OR IDCMP_MENUPICK OR IDCMP_REFRESHWINDOW OR
IDCMP_MOUSEBUTTONS OR IDCMP_GADGETUP OR IDCMP_NEWSIZE
rflags := WFLG_DRAGBAR OR WFLG_ACTIVATE OR WFLG_DEPTHGADGET OR
WFLG_CLOSEGADGET OR WFLG_SMART_REFRESH OR WFLG_SIZEGADGET
checkerr(openlibs())
cleargrid(1)
cleargrid(2)
drawgrid()
new() /* New goal */
move := 0 /* Number of moves by player=0 */
text()
WHILE (parse(Gt_GetIMsg(w.userport)))<>IDCMP_CLOSEWINDOW
IF CtrlC()
closeall()
CleanUp(0)
ENDIF
WaitTOF() /* This is for multitasking friendlyness */
ENDWHILE
closeall()
CleanUp(0)
ENDPROC
/******************************************************************************
*** PROC text
***
*** Puts the Row: Col: text in the window
***/
PROC text()
DEF i
FOR i:=0 TO 2 /* Draw beveled box. Could be replaced with Reqtools func. */
Line(offx+3,basey+(i*15),offx+72, basey+(i*15),1)
Line(offx+3,basey+(i*15),offx+3, basey+12+(i*15),1)
Line(offx+4,basey+(i*15),offx+4, basey+11+(i*15),1)
Line(offx+72,basey+(i*15),offx+72, basey+12+(i*15),2)
Line(offx+71,basey+(i*15)+1,offx+71,basey+13+(i*15),2)
Line(offx+4,basey+12+(i*15),offx+72, basey+12+(i*15),2)
ENDFOR
Colour(1,0)
TextF(offx+6,basey+9, 'Colms:\d[2]',rows)
TextF(offx+6,basey+24,'Rows :\d[2]',columns)
TextF(offx+6,basey+39,'Level:\d[2]',level)
ENDPROC
/******************************************************************************
*** PROC parse
***
*** Evaluates the intuition message
***
***/
PROC parse(msg:PTR TO intuimessage)
DEF myclass
myclass := msg.class
SELECT myclass
CASE IDCMP_MENUPICK
domenu(msg)
CASE IDCMP_CLOSEWINDOW
RETURN myclass
CASE IDCMP_GADGETUP
dogadgets(msg)
CASE IDCMP_NEWSIZE
resize()
CASE IDCMP_REFRESHWINDOW
Gt_BeginRefresh(w)
Gt_EndRefresh(w,TRUE)
CASE IDCMP_MOUSEBUTTONS
IF dobuttons(msg)=1 THEN RtEZRequestA('You\ave won the game!!!','Ok',0,0,0)
ENDSELECT
Gt_ReplyIMsg(msg) /* Again, I don't know why. I saw it */
ENDPROC /* in GadToolsDemo, and it couldn't hurt. */
/******************************************************************************
*** PROC domenu
***
*** Evaluates the intuition message for menupicks
***
***/
PROC domenu(msg:PTR TO intuimessage)
DEF mycode
mycode := msg.code
SELECT mycode
CASE M_ABOUT
RtEZRequestA('WBrain v0.0\nBy Sean Russell\n\nWritten in Amiga_E\nBased on Brain by Andre Wichmann\n©1993 All rites preserved','Ok',0,0,0)
CASE M_UNDO
undo()
CASE M_RETRY
cleargrid(1) /* Clear player grid, and */
move := 0 /* set the number of moves back to 0 */
CASE M_NEW
new()
CASE M_QUIT
closeall()
CleanUp(0)
ENDSELECT
ENDPROC
/******************************************************************************
*** PROC dogadgets
***
*** Evaluates the intuition message for gadget presses
***
***/
PROC dogadgets(msg:PTR TO intuimessage)
DEF mygad,gad:PTR TO gadget
gad:=msg.iaddress
mygad := gad.gadgetid
SELECT mygad
CASE G_UNDO
undo()
CASE G_RETRY
cleargrid(1)
move := 0
CASE G_NEW
new()
CASE G_SLIDER
level := msg.code
text()
new()
ENDSELECT
ENDPROC
/*******************************************************************************
*** PROC dobuttons
***
*** The actual game routine. Checks if the button click was of the right
*** type (buttondown AND leftbutton = $68), checks if the click was in the
*** right range (within the grid on the right side of the window), calculates
*** in which box the click was made, calls "put", calls to see if the game
*** was won with this move, and sets up the undo array.
***/
PROC dobuttons(msg:PTR TO intuimessage)
DEF x,y,t,win
x:= msg.mousex
y:= msg.mousey
IF (msg.code = $68) AND (x >= (wx+5)) AND (x <= ((rows*20)+(wx+5))) AND
(y >= 16) AND (y <= ((columns*20)+16))
x := (x-(wx+5))/20
y := (y-16)/20
t:=gx[x].y
IF t[y] = 0
put(1,x,y,1)
win := checkwin()
move++
moves[move] := (x*10)+y
ENDIF
ENDIF
ENDPROC win
/****************************************************************************
*** PROC undo
***
*** Takes back one move.
***
***/
PROC undo()
DEF x,y
x := moves[move] /10
y := Mod(moves[move],10)
IF move <> 0
put(1,x,y,-1)
moves[move] := 0
move--
ENDIF
ENDPROC
/*******************************************************************************
*** PROC checkwin
***
*** Checks to see if the game is won (by comparing the left grid, goalx, with
*** the right grid, gx)
***/
PROC checkwin()
DEF i,j,win=1,t,u
FOR i := 0 TO (rows-1)
t := gx[i].y
u := goalx[i].y
FOR j := 0 TO (columns-1)
IF t[j] <> u[j] THEN win:=0
ENDFOR
ENDFOR
ENDPROC win
/********************************************************************************
*** PROC openlibs
***
*** Opens the libraries and sets up the window with gadgets and menus.
***/
PROC openlibs()
DEF offs:PTR TO LONG, names:PTR TO LONG, i
IF (reqtoolsbase:=OpenLibrary('reqtools.library',37))=NIL THEN RETURN ER_REQTOOLS
IF (gadtoolsbase := OpenLibrary('gadtools.library', 37))=NIL THEN RETURN ER_LIB
IF (scr:=LockPubScreen('Workbench'))=NIL THEN RETURN ER_WB
IF (visual:=GetVisualInfoA(scr, NIL))=NIL THEN RETURN ER_VISUAL
IF (menu:=CreateMenusA([1,0,'Project',0,0,0,0,
2,0,'About',0,0,0,0,
2,0,'Quit','q',0,0,0,
1,0,'Game',0,0,0,0,
2,0,'Undo','u',0,0,0,
2,0,'Retry','a',0,0,0,
2,0,'New','n',0,0,0,
0,0,0,0,0,0,0]:newmenu, NIL))=NIL THEN RETURN ER_MENUS
IF LayoutMenusA(menu,visual,NIL)=FALSE THEN RETURN ER_MENUS
offx := scr.wborleft + 3
offy := scr.wbortop + 3
basex := (MIN*20)+85+scr.wborleft
basey := 78+scr.wbortop
wx := (rows*20)+85+scr.wborleft
wy := (columns*20)+15
IF wx < basex THEN wx := basex
IF wy < basey THEN wy := basey
IF (g:=CreateContext({glist}))=NIL THEN RETURN ER_CONTEXT
IF (g:=CreateGadgetA(SCROLLER_KIND,g,
[offx,offy+120,75,10,NIL,NIL,0,0,visual,0]:newgadget,
[GTSL_MIN,1,GTSL_MAX,5,GTSL_LEVEL,5,/*GTSL_MAXLEVELLEN,5,*/GA_RELVERIFY,TRUE,
GA_IMMEDIATE,TRUE,GTSC_TOP,0,GTSC_VISIBLE,2,GTSC_TOTAL,5,PGA_FREEDOM,
LORIENT_HORIZ,0]))=NIL THEN RETURN ER_GADGET
offs := [12,32,52]
names := ['Undo','Retry','New']
FOR i := 0 TO 2
IF (g:=CreateGadgetA(BUTTON_KIND,g,
[offx,offy+offs[i],75,20,names[i], PLACETEXT_IN,
i+1,0,visual,0]:newgadget,NIL))=NIL THEN RETURN ER_GADGET
ENDFOR
IF (w:= OpenW(20, 11, ((wx*2)-82)+offx+scr.wborright+10, wy+offy+2, wflags, rflags, 'WBrain v1.0', NIL, 1, glist)) = NIL THEN RETURN ER_WIND
w.minwidth := ((basex*2)-65)+scr.wborright
w.minheight := offy+135
w.maxwidth := (MAX*40)+110+scr.wborleft+scr.wborright
w.maxheight := (MAX*20)+20
IF SetMenuStrip(w, menu)=FALSE THEN RETURN ER_MENUS
Gt_RefreshWindow(w, NIL)
SetTopaz(8) /* Maybe someday I'll make the program font-sensitive... */
Colour(1,0) /* Text color */
ENDPROC
/**************************************************************************
*** PROC closeall
***
*** Closes down everything that is open.
***/
PROC closeall()
IF w THEN ClearMenuStrip(w)
IF menu THEN FreeMenus(menu)
IF visual THEN FreeVisualInfo(visual)
IF w THEN CloseW(w)
IF glist THEN FreeGadgets(glist)
IF scr THEN UnlockPubScreen(NIL, scr)
IF gadtoolsbase THEN CloseLibrary(gadtoolsbase)
IF reqtoolsbase THEN CloseLibrary(reqtoolsbase)
ENDPROC
/*******************************************************************************
*** PROC checkerr
***
*** If an error is found during one of the many opening routines (for gadgets,
*** windows, libraries, etc.), checkerr gets the return code and displays the
*** error.
**/
PROC checkerr(err)
DEF errors:PTR TO LONG
IF err > 0
closeall()
errors:=['', 'open gadtools.library v37', 'lock Workbench',
'get visual info', 'create menus', 'open window',
'create context', 'create gadgets', 'open ReqTools']
WriteF('Couldn\at \s!\n', errors[err])
CleanUp(10)
ENDIF
ENDPROC TRUE
/************************************************************************
*** PROC resize
***
*** Gets a new usersize for the grid.
***/
PROC resize()
DEF buttons,y1
buttons:=offx+80; y1:=offy+10
rows := ((w.width-buttons)-(w.borderright+4)-5)/40
columns := (w.height-(y1+4))/20
wx := (rows*20)+85+scr.wborleft
wy := (columns*20)+15
IF wx < basex THEN wx := basex
IF wy < basey THEN wy := basey
Box(buttons,y1,w.width-(w.borderright+1),w.height-(w.borderbottom+1),0)
text()
cleargrid(1) /* empty the two grids */
cleargrid(2)
drawgrid() /* draw the grids */
new() /* New goal */
ENDPROC
/*************************************************************************
*** PROC cleargrid
***
*** fills the grid with 0s and clears the display grid by calling "put"
*** with value 0.
***/
PROC cleargrid(n)
DEF i,j,t
FOR i := 0 TO (rows-1)
IF n = 1 THEN t := gx[i].y ELSE t:=goalx[i].y
FOR j := 0 TO (columns-1)
t[j] := 0
box(n,i,j,0)
ENDFOR
ENDFOR
ENDPROC
/***************************************************************************
*** PROC drawgrid
***
*** Draws both grids in the window
***/
PROC drawgrid()
DEF i,j,x1,y,x2
FOR i:= 0 TO rows-1
FOR j := 0 TO columns -1
x1 := (i*20)+offx + 80 ; x2 := x1+wx-80
y := (j*20)+offy+10
Line( x1,y, x1+18,y, 2); Line( x2,y, x2+18,y, 2)
Line( x1,y, x1,y+18, 2); Line( x2,y, x2,y+18, 2)
Line( x1+18,y, x1+18,y+18, 1); Line( x2+18,y, x2+18,y+18, 1)
Line( x1,y+18, x1+18,y+18, 1); Line( x2,y+18, x2+18,y+18, 1)
ENDFOR
ENDFOR
ENDPROC
/****************************************************************************
*** PROC new
***
*** New does a lot of work; it clears the two grids and fills the goal
*** grid with a new pattern by randomly choosing empty boxes in the goal
*** grid until it is full. It calls "put" and therefore generates a grid
*** of a random pattern which is solvable by the player.
***/
PROC new()
DEF rnd1,rnd2,i,j,k,x,y,
list[MAXUNDOS]:ARRAY OF CHAR
cleargrid(1)
cleargrid(2)
move :=0
FOR i := 0 TO (MAX-1) /* fill an array with all of the */
FOR j := 0 TO (MAX-1) /* boxes. The coordinates are stored*/
list[(i*10)+j] := (i*10)+j /* as complex numbers; (1,1)=11, */
ENDFOR /* (2,1)=22, etc. */
ENDFOR
FOR i := 0 TO (MAXUNDOS-2) /* Go through MAXUNDOS times and */
rnd1 := Rnd(MAXUNDOS-2) /* swap two random elements each */
rnd2 := Rnd(MAXUNDOS-2) /* time. This gives us our random */
j := list[rnd1] /* selection. */
list[rnd1] := list[rnd2]
list[rnd2] := j
ENDFOR
k:=0
FOR i := 1 TO rows /* Now we put the boxes in this */
FOR j := 1 TO columns /* random order we've set up. We */
x := list[k]/10 /* have to make sure that each is a */
y := Mod(list[k],10) /* valid box value for the number of*/
k := k+1 /* rows and columns we have. */
WHILE ((x>(rows-1)) OR (y>(columns-1))) AND (k < (MAXUNDOS-1))
x := list[k]/10 /* If it's not valid, we have to */
y := Mod(list[k],10) /* step through the list until we */
k := k+1 /* find one that is. */
ENDWHILE
put(2,x,y,1)
ENDFOR
ENDFOR
ENDPROC
/****************************************************************************
*** PROC put
***
*** Puts a box. n is the grid number (1=gx, 2=goalx), x and y are, of
*** course, the box coordinates, and "as" is either 1 or -1. If as is -1,
*** then we're undoing boxes; that is, we're taking a box out of the grid,
*** rather than putting one in.
*** The levels are handled here:
*** level 0: Normal play (add to the four primary neighbors)
*** level 1: Add to all 8 neighbors
*** level 2: Add to primary neighbors and primary neighbors 2 away
*** level 3: Add to all 8 neighbors and all neigbors 2 away
***/
PROC put(n,x,y,as)
DEF i, j, target,start=-1, end=1
IF level>1
start:=-2; end:=2
ENDIF
FOR i := start TO end
FOR j := start TO end
IF ((i=0) OR (j=0)) OR ((level=1) OR (level=3))
target := IF ((i=0) AND (j=0)) THEN 1 ELSE 0
putsub(n,x+i,y+j,as,target)
ENDIF
ENDFOR
ENDFOR
ENDPROC
/***********************************************************************
*** PROC putsub
***
*** Just an extension routine for put.
*** This adds one to x,y if grid[x][y] = 0 AND target = TRUE or if
*** grid[x][y]<>0 AND target = FALSE.
**/
PROC putsub(n,x,y,as,target)
DEF t
IF ((x<rows) AND (x>=0) AND (y<columns) AND (y>=0))
IF n=1 THEN t:=gx[x].y ELSE t:=goalx[x].y
IF t[y]=0
IF target=1
t[y]:=1
box(n,x,y,t[y])
ENDIF
ELSE
t[y] := t[y] + as
IF t[y] = 5
t[y] := 1
ELSEIF t[y]=0
t[y]:=IF target=1 THEN 0 ELSE 4
ENDIF
box(n,x,y,t[y])
ENDIF
ENDIF
ENDPROC
/***********************************************************************
*** PROC box
***
*** Draws a colored box in a specified grid coordinate. n is the grid
*** number (1=right grid, 2=left grid), x and y are the coordinates,
*** and v is the number to draw. If v is (1-4), then box will also put
*** the number in the box. If v is 0, then it simply clears the box.
***/
PROC box(n,x,y,v)
DEF x1,y1,colors:PTR TO LONG
colors := [0,3,4,5,6]
x1 := (x*20)+offx + wx
IF n = 2 THEN x1 := x1-wx+80
y1 := (y*20)+offy+10
Box( x1+1,y1+1, x1+17,y1+17, colors[v])
Colour(1,colors[v])
IF v>0 THEN TextF(x1+5,y1+11,'\d[1]',v)
ENDPROC