Mercurial > rg
changeset 0:62966dd383ed default tip
initial
| author | Radomir Dopieralski <sheep-devel@sheep.art.pl> |
|---|---|
| date | Sun, 08 Dec 2013 19:39:15 +0100 |
| parents | |
| children | |
| files | config.pas console.pas creature.pas editcfg/items.cfg editcfg/keys.cfg editcfg/levels.cfg editcfg/main.cfg editcfg/messages.cfg editcfg/monsters.cfg editcfg/rooms.cfg editcfg/tiles.cfg global.pas items.pas level.pas light.pas maps.pas parser.pas player.pas porting.pas r.pas save.pas |
| diffstat | 21 files changed, 4445 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/config.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,435 @@ +{ Configuration reading routines. } + +UNIT Config; + +INTERFACE + +PROCEDURE ReadCfg; + +IMPLEMENTATION + +USES Global, Console, Parser, Porting; + +PROCEDURE ParseError; +BEGIN + Txt(Concat('@rParse error at line @R',Num(actLine),'@r.')); + CASE errNum OF + PARSE_ERR_EOF: Txt('@RUnexpected end of file!'); + PARSE_ERR_NAM: Txt('@RVariable name expected!'); + PARSE_ERR_STR: Txt('@RString constant expected!'); + PARSE_ERR_NUM: Txt('@RNumeric constant expected!'); + PARSE_ERR_OPN: Txt('@RCan''t open/close file!'); + ELSE Txt('@RUnknown error!'); + END; + Msg('Press any key...'); + GetKey; + ResetScr; + Halt(1); +END; + + +PROCEDURE ReadCfg; +VAR tmpLine: WORD; + + +PROCEDURE ReadMonsters(filename:STRING); +VAR f: CfgFile; + n: STRING; + i: BYTE; + p: CreatDef; + +BEGIN + tmpLine:=actLine;; + + OpenCfg(f,Concat(DATADIR,filename)); + IF errNum<>PARSE_NOERROR THEN ParseError; + + monsterlist:=NIL; + p:=NIL; + REPEAT + n:=ReadName(f); + IF n<>'END' THEN + IF n='MONSTER' THEN BEGIN + New(p); + i:=ReadNumber(f); + p^.id:=i; + p^.nam:=''; + p^.hp:=100; + p^.spd:=100; + p^.next:=monsterlist; + monsterlist:=p; + END ELSE + IF n='NAME' THEN p^.nam:=ReadString(f) ELSE + IF n='HPMAX' THEN p^.hp:=ReadNumber(f) ELSE + IF n='SPEED' THEN p^.spd:=ReadNumber(f) ELSE + IF n='LOOKS' THEN BEGIN + n:=ReadString(f); + p^.chr:=n[1]; + p^.atr:=ReadNumber(f); + END ELSE + BEGIN errNum:=PARSE_ERR_NAM; ParseError END; + IF errNum<>PARSE_NOERROR THEN ParseError; + UNTIL n='END'; + CloseCfg(f); + actLine:=tmpLine; +END; + +PROCEDURE ReadItems(filename:STRING); +VAR f: CfgFile; + n: STRING; + i: BYTE; + p: ItemDef; + +BEGIN + tmpLine:=actLine;; + + OpenCfg(f,Concat(DATADIR,filename)); + IF errNum<>PARSE_NOERROR THEN ParseError; + + itemlist:=NIL; + p:=NIL; + REPEAT + n:=ReadName(f); + IF n<>'END' THEN + IF n='ITEM' THEN BEGIN + New(p); + i:=ReadNumber(f); + p^.id:=i; + p^.flg:=[]; + p^.dsc:=' '; + p^.unk:=i; + p^.qnt:=1; + p^.eqp:=0; + p^.wgt:=1; + p^.next:=itemlist; + itemlist:=p; + END ELSE + IF n='NAME' THEN p^.nam:=ReadString(f) ELSE + IF n='DESC' THEN p^.dsc:=ReadString(f) ELSE + IF n='LOOKS' THEN BEGIN + n:=ReadString(f); + p^.chr:=n[1]; + p^.atr:=ReadNumber(f); + END ELSE + IF n='EQUIP' THEN p^.eqp:=ReadNumber(f) ELSE + IF n='WEIGHT' THEN p^.wgt:=ReadNumber(f) ELSE + IF n='QUANTITY' THEN p^.qnt:=ReadNumber(f) ELSE + IF n='UNKNOWN' THEN p^.unk:=ReadNumber(f) ELSE + IF n='MULTIPLE' THEN p^.flg:=p^.flg+[ITEM_MULTIPLE] ELSE + IF n='KNOWN' THEN p^.flg:=p^.flg+[ITEM_KNOWN] ELSE + IF n='EMPTY' THEN p^.flg:=p^.flg+[ITEM_EMPTY] ELSE + BEGIN errNum:=PARSE_ERR_NAM; ParseError END; + + IF errNum<>PARSE_NOERROR THEN ParseError; + UNTIL n='END'; + CloseCfg(f); + actLine:=tmpLine; +END; + + +PROCEDURE ReadLevels(filename:STRING); +VAR f: CfgFile; + n: STRING; + x,y: INTEGER; + p: pLevel; + place: INTEGER; +BEGIN + + tmpLine:=actLine;; + + OpenCfg(f,Concat(DATADIR,filename)); + IF errNum<>PARSE_NOERROR THEN ParseError; + + place:=1; + levellist:=NIL; + + REPEAT + n:=ReadName(f); + IF n<>'END' THEN + IF n='LEVEL' THEN BEGIN + New(p); + p^.id:=ReadNumber(f); + p^.erosion:=0; + p^.next:=levellist; + FOR x:=1 TO MAXROOMS DO BEGIN + p^.rooms[x].rom:=0; + p^.rooms[x].qnt:=255; + p^.rooms[x].dor:=0; + FOR y:=1 TO MAXROOMS DO p^.rooms[x].con[y]:=0; + END; + levellist:=p; + END ELSE + IF n='NAME' THEN p^.name:=ReadString(f) ELSE + IF n='ROOM' THEN BEGIN + place:=ReadNumber(f); + IF (place>MAXROOMS) OR (place<1) THEN place:=MAXROOMS; + p^.rooms[place].rom:=ReadNumber(f); + END ELSE + IF n='DOOR' THEN p^.rooms[place].dor:=ReadNumber(f) ELSE + IF n='QUANTITY' THEN p^.rooms[place].qnt:=ReadNumber(f) ELSE + IF n='CONNECT' THEN BEGIN + FOR x:=1 TO MAXROOMS DO + p^.rooms[place].con[x]:=ReadNumber(f); + END ELSE + IF n='ERODE' THEN p^.erosion:=ReadNumber(f) ELSE + IF n='BACK' THEN FOR x:=0 TO 9 DO p^.back[x]:=ReadNumber(f) ELSE + IF n='MAP' THEN FOR y:=0 TO 3 DO FOR x:=0 TO 3 DO p^.map[x,y]:=ReadNumber(f) ELSE + BEGIN errNum:=PARSE_ERR_NAM; ParseError END; + + IF errNum<>PARSE_NOERROR THEN ParseError; + UNTIL n='END'; + CloseCfg(f); + actLine:=tmpLine; +END; + +PROCEDURE ReadRooms(filename:STRING); +VAR f: CfgFile; + n: STRING; + x,y: INTEGER; + t: ARRAY[0..255] OF BYTE; + p: pRoom; +BEGIN + FOR x:=0 TO 255 DO t[x]:=0; + + tmpLine:=actLine;; + + OpenCfg(f,Concat(DATADIR,filename)); + IF errNum<>PARSE_NOERROR THEN ParseError; + + + roomlist:=NIL; + + REPEAT + n:=ReadName(f); + IF n<>'END' THEN + IF n='ROOM' THEN BEGIN + New(p); + p^.id:=ReadNumber(f); + p^.flg:=[]; + FOR y:=0 TO 15 DO BEGIN + n:=ReadString(f); + FOR x:=0 TO 15 DO p^.map[x,y]:=t[Ord(n[x+1])]; + END; + p^.next:=roomlist; + roomlist:=p; + END ELSE + IF n='DOOR' THEN BEGIN IF p<>NIL THEN BEGIN + p^.dor:=ReadNumber(f); + END END ELSE + IF n='EASYDOOR' THEN p^.flg:=p^.flg+[ROOM_EASYDOOR] ELSE + IF n='UNIQUE' THEN p^.flg:=p^.flg+[ROOM_UNIQUE] ELSE + IF n='CHAR' THEN BEGIN + n:=ReadString(f); + t[Ord(n[1])]:=ReadNumber(f); + END ELSE + BEGIN errNum:=PARSE_ERR_NAM; ParseError END; + + IF errNum<>PARSE_NOERROR THEN ParseError; + UNTIL n='END'; + CloseCfg(f); + actLine:=tmpLine; +END; + +PROCEDURE ReadKeys(filename:STRING); +VAR x: INTEGER; + n: STRING; + f: CfgFile; + +BEGIN + tmpLine:=actLine;; + + OpenCfg(f,Concat(DATADIR,filename)); + IF errNum<>PARSE_NOERROR THEN ParseError; + + + REPEAT + n:=ReadName(f); + IF n<>'END' THEN + IF n='KEY' THEN BEGIN + x:=ReadNumber(f); + n:=ReadString(f); + IF x<=MAXCMD THEN BEGIN + IF (n[1]='~') AND (length(n)>1) THEN CASE n[2] OF + '~': n[1]:='~'; + 'A': n[1]:=KEYCHR_DIR1; + 'B': n[1]:=KEYCHR_DIR2; + 'C': n[1]:=KEYCHR_DIR3; + 'D': n[1]:=KEYCHR_DIR4; + 'E': n[1]:=KEYCHR_DIR5; + 'F': n[1]:=KEYCHR_DIR6; + 'G': n[1]:=KEYCHR_DIR7; + 'H': n[1]:=KEYCHR_DIR8; + 'I': n[1]:=KEYCHR_DIR9; + 'n': n[1]:=KEYCHR_CR; + 'b': n[1]:=KEYCHR_BS; + 't': n[1]:=KEYCHR_TAB; + END; + Cmd[x]:=n[1]; + END; + END ELSE + BEGIN errNum:=PARSE_ERR_NAM; ParseError END; + IF errNum<>PARSE_NOERROR THEN ParseError; + UNTIL n='END'; + CloseCfg(f); + actLine:=tmpLine; +END; + +PROCEDURE ReadTiles(filename:STRING); +VAR n: STRING; + f: CfgFile; + p: TileDef; + +BEGIN + tmpLine:=actLine;; + + OpenCfg(f,Concat(DATADIR,filename)); + IF errNum<>PARSE_NOERROR THEN ParseError; + + + tilelist:=NIL; + REPEAT + n:=ReadName(f); + IF n<>'END' THEN + IF n='TILE' THEN BEGIN + New(p); + p^.id:=ReadNumber(f); + p^.flg:=[]; + p^.vis:=5; + p^.drp:=0; + p^.mov:=30; + p^.next:=tilelist; + tilelist:=p; + END ELSE + IF n='NAME' THEN BEGIN + p^.nam:=ReadString(f); + END ELSE + IF n='LOOKS' THEN BEGIN + n:=ReadString(f); + p^.chr:=n[1]; + p^.atr:=ReadNumber(f); + END ELSE + IF n='CHANGETO' THEN p^.chn:=ReadNumber(f) ELSE + IF n='VISION' THEN p^.vis:=ReadNumber(f) ELSE + IF n='MOVE' THEN p^.mov:=ReadNumber(f) ELSE + IF n='DESTROYTO' THEN p^.dst:=ReadNumber(f) ELSE + IF n='DROPITEM' THEN p^.drp:=ReadNumber(f) ELSE + IF n='OPERATE' THEN p^.flg:=p^.flg+[TILE_OPERATE] ELSE + IF n='ENTER' THEN p^.flg:=p^.flg+[TILE_ENTER] ELSE + IF n='EXIT' THEN p^.flg:=p^.flg+[TILE_EXIT] ELSE + IF n='SMARTDOOR' THEN p^.flg:=p^.flg+[TILE_SMARTDOOR] ELSE + IF n='FRAGILE' THEN p^.flg:=p^.flg+[TILE_FRAGILE] ELSE + IF n='BURN' THEN p^.flg:=p^.flg+[TILE_BURN] ELSE + IF n='SWIM' THEN p^.flg:=p^.flg+[TILE_SWIM] ELSE + IF n='UPPER' THEN p^.flg:=p^.flg+[TILE_UPPER] ELSE + IF n='ITEM' THEN p^.flg:=p^.flg+[TILE_ITEM] ELSE + BEGIN errNum:=PARSE_ERR_NAM; ParseError END; + + IF errNum<>PARSE_NOERROR THEN ParseError; + UNTIL n='END'; + CloseCfg(f); + actLine:=tmpLine; +END; + +PROCEDURE ReadMessages(filename:STRING); +VAR n: STRING; + x,hl,dl,ml: INTEGER; + f: CfgFile; +BEGIN + tmpLine:=actLine;; + + OpenCfg(f,Concat(DATADIR,filename)); + IF errNum<>PARSE_NOERROR THEN ParseError; + + + stat_string:=''; + FOR hl:=0 TO MAXLONGSTRING DO BEGIN + help_string[hl]:=''; + death_string[hl]:=''; + END; + hl:=0; + dl:=0; + ml:=0; + + REPEAT + n:=ReadName(f); + IF n<>'END' THEN + IF n='STAT' THEN stat_string:=Concat(stat_string,'@n@m',ReadString(f)) ELSE + IF n='HELP' THEN BEGIN + help_string[hl]:=ReadString(f); + IF hl<MAXLONGSTRING THEN Inc(hl); + END ELSE + IF n='DEATH' THEN BEGIN + death_string[dl]:=ReadString(f); + IF dl<MAXLONGSTRING THEN Inc(dl); + END ELSE + IF n='MENU' THEN BEGIN + menu_string[ml]:=ReadString(f); + IF ml<MAXLONGSTRING THEN Inc(ml); + END ELSE + IF n='MSG' THEN BEGIN + x:=ReadNumber(f); + n:=ReadString(f); + IF x<=MAXMSG THEN Msgs[x]:=n; + END ELSE + BEGIN errNum:=PARSE_ERR_NAM; ParseError END; + + IF errNum<>PARSE_NOERROR THEN ParseError; + UNTIL n='END'; + CloseCfg(f); + actLine:=tmpLine; +END; + + +PROCEDURE ReadMain; +VAR n: STRING; + Pal: PalAry; + x: INTEGER; + f: CfgFile; + +BEGIN + OpenCfg(f,Concat(DATADIR,MAINCFG)); + IF errNum<>PARSE_NOERROR THEN ParseError; + + + REPEAT + n:=ReadName(f); + IF n<>'END' THEN + IF n='SHOW' THEN Txt(ReadString(f)) ELSE + IF n='VERSION' THEN Txt(Concat('Version @M',VERSION,'@m.')) ELSE + IF n='KEYS' THEN ReadKeys(ReadString(f)) ELSE + IF n='TILES' THEN ReadTiles(ReadString(f)) ELSE +{ IF n='TOWN' THEN ReadMap(ReadString(f)) ELSE } + IF n='ROOMS' THEN ReadRooms(ReadString(f)) ELSE + IF n='LEVELS' THEN ReadLevels(ReadString(f)) ELSE + IF n='ITEMS' THEN ReadItems(ReadString(f)) ELSE + IF n='MONSTERS' THEN ReadMonsters(ReadString(f)) ELSE + IF n='TEXT' THEN ReadMessages(ReadString(f)) ELSE + IF n='SHDCOLOR' THEN shadecolor:=ReadNumber(f) ELSE + IF n='MSGCOLOR' THEN MSGCOL:=ReadNumber(f) ELSE + IF n='SCROLL' THEN margin:=ReadNumber(f) ELSE + IF n='PALETTE' THEN BEGIN + FOR x:=0 TO 15 DO BEGIN + Pal[x].r:=ReadNumber(f); + Pal[x].g:=ReadNumber(f); + Pal[x].b:=ReadNumber(f); + END; + ChPal(Pal); + END ELSE + IF n='ID' THEN pc.id:=ReadString(f) ELSE + IF n='LEVEL' THEN BEGIN + pc.intown:=TRUE; + pc.lev:=ReadNumber(f); + END ELSE + BEGIN errNum:=PARSE_ERR_NAM; ParseError END; + + IF errNum<>PARSE_NOERROR THEN ParseError; + UNTIL n='END'; + CloseCfg(f); +END; + + +BEGIN + ReadMain; +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/console.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,340 @@ +{ Display and input routines. } + +UNIT Console; + +INTERFACE + +USES Porting; + +CONST MSGCOL:BYTE=6; { Default messages color. } + +PROCEDURE Msg(m:STRING); { Displays string as a message on the right of the screen. } +PROCEDURE Txt(m:STRING); { Displays string as a text on the left of the screen. } +PROCEDURE Stat(m:STRING); { Displays string in the upper right part of the screen. } +PROCEDURE PrepScr; { Prepares screen (actually does nothing) } +PROCEDURE ResetScr; { Brings the screen to previous condition. } +PROCEDURE ClrMsg; { Clears the messages window. } +PROCEDURE ClrTxt; { Clears the text/map window. } +PROCEDURE PutChr(x,y: INTEGER; c:CHAR; a:BYTE); { Displays a character on the screen. } +PROCEDURE Cursor(x,y: INTEGER); { Changes cursor position. } + +FUNCTION GetKey:CHAR; { Reads a character from keyboard. } +FUNCTION GetString(l:BYTE):STRING; { Allows to input a string. L sets maximum string length. } + +FUNCTION Number(n: INTEGER):STRING; { Converts number into a string, three characters long. } +FUNCTION Num(n: INTEGER):STRING; { Converts number into a string. } +FUNCTION Replace(s,a,b:STRING):STRING; { Replaces the first occurance of A in string S with B. } +FUNCTION Capitalize(s:STRING): STRING; { Changes the first letter in the string to upper case. } +FUNCTION Plural(s:STRING):STRING; { Replaces '@s' and makes proper plural form. } + +IMPLEMENTATION + +VAR nnl: BOOLEAN; { No new line -- should next msg change line? } + line,txtline: INTEGER; + +FUNCTION Capitalize(s:STRING):STRING; +VAR t: STRING; +BEGIN + IF s='' THEN Exit; + t:=s; + t[1]:=UpCase(t[1]); + Capitalize:=t; +END; + +FUNCTION Plural(s:STRING):STRING; +BEGIN + s:=Replace(s, 'y@s' , 'ies' ); + s:=Replace(s, 'fe@s', 'ves' ); + s:=Replace(s, 'ff@s', 'ves' ); + s:=Replace(s, 'ex@s', 'icies'); + s:=Replace(s, 'va@s', 'vae' ); + s:=Replace(s, 's@s' , 'ses' ); + s:=Replace(s, '@s' , 's' ); + + Plural:=s; +END; + +FUNCTION Replace(s,a,b:STRING):STRING; +VAR d: INTEGER; +BEGIN + d:=Pos(a,s); + Replace:=s; + IF d<=0 THEN Exit; + Delete(s,d,Length(a)); + Insert(b,s,d); + Replace:=s; +END; + + +PROCEDURE PutChr(x,y: INTEGER;c: CHAR; a:BYTE); +BEGIN + IF (NOT pal_changed) THEN BEGIN + IF (a=14) THEN a:=6; + IF (a=13) THEN a:=14; + END; + PutChar(x,y,c,a); +END; + +PROCEDURE Cursor(x,y: INTEGER); +BEGIN + GotoXY(x,y); +END; + +PROCEDURE ClrMsg; +VAR x,y: INTEGER; +BEGIN + FOR y:=5 TO 24 DO + FOR x:=50 TO 79 DO PutChar(x,y,' ',$07); + line:=0; + nnl:=TRUE; +END; + +PROCEDURE Msg(m:STRING); +VAR i,p: INTEGER; + a,l: BYTE; + +PROCEDURE NewLine; +BEGIN + IF line>=19 THEN ScrollWin(50,5,79,24) + ELSE Inc(line); + i:=0; +END; + +BEGIN + IF NOT nnl THEN NewLine ELSE BEGIN + FOR i:=50 TO 79 DO PutChar(i,line+5,' ',MSGCOL); + i:=0; + END; + nnl:=FALSE; + p:=1; + a:=MSGCOL; + l:=Length(m); + REPEAT + WHILE m[p]='@' DO BEGIN + Inc(p); + CASE m[p] OF + 'd': a:=0; + 'b': a:=1; + 'g': a:=2; + 'c': a:=3; + 'r': a:=4; + 'p': a:=5; + 'o': a:=6; + 'w': a:=7; + 'D': a:=8; + 'B': a:=9; + 'G': a:=10; + 'C': a:=11; + 'R': a:=12; + 'P': a:=13; + 'O': a:=14; + 'W': a:=15; + 'm': a:=MSGCOL; + 'M': a:=MSGCOL XOR $08; + 'n': NewLine; + 'N': nnl:=TRUE; + '@': Break; + END; + Inc(p); + END; + IF p>l THEN Exit; + IF i>29 THEN NewLine; + PutChar(50+i,line+5,m[p],a); + Inc(i); + Inc(p); + UNTIL FALSE; +END; + +PROCEDURE ClrTxt; +VAR x,y: INTEGER; +BEGIN + FOR y:=0 TO 24 DO + FOR x:=0 TO 49 DO PutChar(x,y,' ',$07); + txtline:=-1; +END; + + +PROCEDURE Txt(m:STRING); +VAR i,p: INTEGER; + a,l: BYTE; + +PROCEDURE NewLine; +BEGIN + IF txtline>=24 THEN ScrollWin(0,0,49,24) + ELSE Inc(txtline); + i:=0; +END; + +BEGIN + NewLine; + p:=1; + a:=MSGCOL; + l:=Length(m); + REPEAT + WHILE m[p]='@' DO BEGIN + Inc(p); + CASE m[p] OF + 'd': a:=0; + 'b': a:=1; + 'g': a:=2; + 'c': a:=3; + 'r': a:=4; + 'p': a:=5; + 'o': a:=6; + 'w': a:=7; + 'D': a:=8; + 'B': a:=9; + 'G': a:=10; + 'C': a:=11; + 'R': a:=12; + 'P': a:=13; + 'O': a:=14; + 'W': a:=15; + 'm': a:=MSGCOL; + 'M': a:=MSGCOL XOR $08; + 'n': NewLine; + '@': Break; + END; + Inc(p); + END; + IF p>l THEN Exit; + IF i>49 THEN NewLine; + PutChar(i,txtline,m[p],a); + Inc(i); + Inc(p); + UNTIL FALSE; +END; + +FUNCTION GetString(l:BYTE):STRING; +VAR c: CHAR; + s: STRING; + i: INTEGER; + a: BYTE; + +PROCEDURE NewLine; +BEGIN + IF line>=19 THEN ScrollWin(50,5,79,24) + ELSE Inc(line); + i:=0; +END; + +BEGIN + IF l=0 THEN Exit; + IF l>30 THEN l:=30; + + IF NOT nnl THEN NewLine ELSE BEGIN + FOR i:=50 TO 79 DO PutChar(i,line+5,' ',MSGCOL); + i:=0; + END; + + + a:=MSGCOL XOR $08; + nnl:=TRUE; + + s:=''; + i:=0; + REPEAT + GotoXY(50+i,line+5); + c:=GetKey; + IF (i<l) AND (c>=' ') AND (c<#127) THEN BEGIN + s:=Concat(s,c); + PutChar(50+i,line+5,c,a); + Inc(i); + END; + IF c=KEYCHR_BS THEN BEGIN + IF i>0 THEN Dec(i); + PutChar(50+i,line+5,' ',a); + s:=Copy(s,1,length(s)-1); + END; + UNTIL (c=KEYCHR_CR); + GetString:=s; +END; + +PROCEDURE Stat(m:STRING); +VAR a: BYTE; + i,p: INTEGER; + +PROCEDURE NewLine; +BEGIN + ScrollWin(50,0,79,4); + i:=0; +END; + +BEGIN + NewLine; + p:=1; + a:=MSGCOL; + REPEAT + WHILE m[p]='@' DO BEGIN + Inc(p); + CASE m[p] OF + 'd': a:=0; + 'b': a:=1; + 'g': a:=2; + 'c': a:=3; + 'r': a:=4; + 'p': a:=5; + 'o': a:=6; + 'w': a:=7; + 'D': a:=8; + 'B': a:=9; + 'G': a:=10; + 'C': a:=11; + 'R': a:=12; + 'P': a:=13; + 'O': a:=14; + 'W': a:=15; + 'm': a:=MSGCOL; + 'M': a:=MSGCOL XOR $08; + 'n': NewLine; + 'v': ; + '@': Break; + END; + Inc(p); + END; + IF i>29 THEN NewLine; + PutChar(50+i,4,m[p],a); + Inc(p); + Inc(i); + UNTIL (p>Length(m)); +END; + +FUNCTION Number(n: INTEGER):STRING; +VAR s: STRING[3]; +BEGIN + Str(n:3,s); + Number:=s; +END; + +FUNCTION Num(n: INTEGER):STRING; +VAR s: STRING; +BEGIN + Str(n,s); + Num:=s; +END; + +PROCEDURE PrepScr; +VAR x,y: INTEGER; +BEGIN +{ FOR y:=0 TO 24 DO + FOR x:=0 TO 79 DO PutChar(x,y,' ',$07);} +END; + +PROCEDURE ResetScr; +VAR i,x,y:BYTE; +BEGIN + FOR y:=0 TO 24 DO FOR x:=0 TO 79 DO PutChar(x,y,' ',$07); + GotoXY(0,0); + ResetPal; +END; + +FUNCTION GetKey:CHAR; +BEGIN + GetKey:=GetChr; +END; + +BEGIN + line:=0; + nnl:=TRUE; +END. +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/creature.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,155 @@ +{ Creature handling routines. } + +UNIT Creature; + +INTERFACE +USES Global; + +FUNCTION GenerateMonster(id:WORD): pCreat; +PROCEDURE ShowMonster(m: pMap); +PROCEDURE MoveMonster(x,y: INTEGER; creat:pCreat); +PROCEDURE BulletFly(x1,y1,x2,y2: INTEGER); +PROCEDURE MonsterAI(creat:pCreat); + +IMPLEMENTATION + +USES Console, Maps; + + +PROCEDURE ShowMonster(m: pMap); +BEGIN + Msg(Replace(msgs[5],'@v',m^.crt^.def^.nam)); + Msg(Concat('@cHis hit points: @C',Num(m^.crt^.hp),'@c/@C',Num(m^.crt^.def^.hp))); + Msg(Concat('@cHis next move time: @C',Num(m^.crt^.mov))); + +END; + + +PROCEDURE MoveMonster(x,y: INTEGER; creat:pCreat); +VAR m,n: pMap; +BEGIN + m:=GetMap(x,y); + + + IF creat=NIL THEN Exit; + IF m^.crt<>NIL THEN Exit; + IF (m^.ter^.mov>=100) THEN Exit; + + n:=GetMap(creat^.x,creat^.y); + + n^.crt:=NIL; + m^.crt:=creat; + creat^.x:=x; + creat^.y:=y; + + Inc(creat^.mov,m^.ter^.mov); +END; + + +FUNCTION GenerateMonster(id:WORD): pCreat; +VAR creat: pCreat; + monster: CreatDef; +BEGIN + monster:=FindMonster(id); + New(creat); + creat^.x:=-1; { monster starts in Limbo } + creat^.def:=monster; + creat^.mov:=gametime; + creat^.hp:=creat^.def^.hp; + creat^.next:=allmonsters; + allmonsters:=creat; + GenerateMonster:=creat; +END; + +PROCEDURE MonsterAI(creat:pCreat); +VAR x,y: INTEGER; +BEGIN + IF creat=NIL THEN Exit; + + IF creat^.x<0 THEN Exit; + + x:=creat^.x; + y:=creat^.y; + + IF (MAP_VISIBLE IN GetMap(x,y)^.flg) THEN BEGIN + IF (playchr^.x>x) AND (FreeToMove(GetMap(x+1,y))) THEN Inc(x); + IF (playchr^.x<x) AND (FreeToMove(GetMap(x-1,y))) THEN Dec(x); + IF (playchr^.y>y) AND (FreeToMove(GetMap(x,y+1))) THEN Inc(y); + IF (playchr^.y<y) AND (FreeToMove(GetMap(x,y-1))) THEN Dec(y); + END; + + IF (x<>creat^.x) OR (y<>creat^.y) THEN BEGIN + MoveMonster(x,y,creat); + END ELSE Inc(creat^.mov,50); +END; + +PROCEDURE BulletFly(x1,y1,x2,y2: INTEGER); +VAR i,dx,dy,j,d, c1, c2,x, a1, a2,y, b1, b2: INTEGER; + m: pMap; +BEGIN + dx:=Abs(x2-x1); + dy:=Abs(y2-y1); + + IF dx>=dy THEN BEGIN + j:=dx+1; + d:=(dy*2)-dx; + c1:=dy*2; + c2:=(dy-dx)*2; + a1:=1; + a2:=1; + b1:=0; + b2:=1; + END ELSE BEGIN + j:=dy+1; + d:=(dx*2)-dy; + c1:=dx*2; + c2:=(dx-dy)*2; + a1:=0; + a2:=1; + b1:=1; + b2:=1; + END; + + IF x1>x2 THEN BEGIN + a1:=-a1; + a2:=-a2; + END; + + IF y1>y2 THEN BEGIN + b1:=-b1; + b2:=-b2; + END; + + x:=x1; + y:=y1; + + IF (d < 0) THEN BEGIN + Inc(d,c1); + Inc(x,a1); + Inc(y,b1); + END ELSE BEGIN + Inc(d,c2); + Inc(x,a2); + Inc(y,b2); + END; + + WHILE InMap(x,y) DO BEGIN + m:=GetMap(x,y); + IF m^.ter^.mov>=100 THEN BEGIN + Demolish(m); + Exit; + END; + + IF (d < 0) THEN BEGIN + Inc(d,c1); + Inc(x,a1); + Inc(y,b1); + END ELSE BEGIN + Inc(d,c2); + Inc(x,a2); + Inc(y,b2); + END; + END; +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/editcfg/items.cfg Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,115 @@ +# +# This is items definition file. +# ============================== +# +# Do not modify it unless you know what you are doing. +# The parser is very sensitive to syntax errors (program may crash). +# +# Understandig: +# ------------- +# +# ITEM ItemID - Begining of an entry. +# NAME ItemName - Name of the item (@s marks plural 's', @a marks quantity). +# LOOKS Character Color - Character and color to represent the item. +# UNKNOWN ItemID - Looks like the other item when not identyfied. +# EQUIP Slot - You can equip it into Slot. +# +# Slot values: +# 0 - Can't equip (default); +# 1 - Pack; +# 2 - Wear; +# +# MULTIPLE - Allows items to stack +# KNOWN - Already idetified +# EMPTY - You can put an item into it. +# + +# Special 'no item' item: +# --------------------- + +ITEM 0 + NAME "nothing" + DESC "There is nothing here." + LOOKS "-" 7 + +# Special 'many items' item: +# -------------------------- + +ITEM 1 + NAME "@a pile@s of items" + DESC "Several items are lying here." + LOOKS "%" 7 + EMPTY + +# Testing items: +# -------------- + + +ITEM 2 + NAME "@a strange berry@s" + LOOKS "," 4 + DESC "Looks tasty..." + QUANTITY 5 + KNOWN MULTIPLE + WEIGHT 1 + +ITEM 3 + NAME "@a berry@s of healing" + LOOKS "," 4 + DESC "Smells nice, looks nice, tastes nice. It heals you." + QUANTITY 5 + UNKNOWN 2 + MULTIPLE + WEIGHT 1 + +ITEM 4 + NAME "@a rock@s" + LOOKS "\"" 8 + DESC "Small, grey rock with some sharp edges." + KNOWN MULTIPLE + WEIGHT 3 + +ITEM 5 + NAME "@a space marine uniform@s" + LOOKS "[" 2 + DESC "Green millitary uniform with some space marines insignias on it." + EQUIP 2 + KNOWN + WEIGHT 15 + +ITEM 6 + NAME "@a millitary backpack@s" + LOOKS "%" 2 + DESC "Large green backpack." + EQUIP 1 + KNOWN EMPTY + WEIGHT 20 + +# Debris: +# ------- + +ITEM 10 + NAME "@a piece@s of junk" + LOOKS "~" 11 + QUANTITY 10 + KNOWN MULTIPLE + WEIGHT 5 + +ITEM 11 + NAME "@a pebble@s" + LOOKS "\"" 8 + QUANTITY 30 + KNOWN MULTIPLE + WEIGHT 3 + +ITEM 12 + NAME "@a piece@s of wood" + LOOKS ")" 14 + QUANTITY 10 + KNOWN MULTIPLE + WEIGHT 5 + +# End of file. +# ------------ + +END \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/editcfg/keys.cfg Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,81 @@ +# +# This is keyboard definition file. +# ================================= +# +# +# Understanding: +# -------------- +# +# KEY CommandID Character +# +# Special keys: +# ------------- +# ~~ - Tilde +# ~A - Keypad 1 +# ~B - Keypad 2 +# ~C - Keypad 3 +# ~D - Keypad 4 +# ~E - Keypad 5 +# ~F - Keypad 6 +# ~G - Keypad 7 +# ~H - Keypad 8 +# ~I - Keypad 9 +# ~b - Backspace +# ~t - Tab +# ~n - Return +# + +# Direction keys: +# --------------- +KEY 1 "~A" # Direction 1 +KEY 2 "~B" # Direction 2 +KEY 3 "~C" # Direction 3 +KEY 4 "~D" # Direction 4 +KEY 5 "." # Direction 5 +KEY 6 "~F" # Direction 6 +KEY 7 "~G" # Direction 7 +KEY 8 "~H" # Direction 8 +KEY 9 "~I" # Direction 9 + +# Commands: +# --------- + +KEY 10 "Q" # Quit +KEY 11 "o" # Operate +KEY 12 "l" # Look +KEY 13 "?" # Help +KEY 14 ">" # Enter +KEY 15 "e" # Examine equipment +KEY 16 ";" # Pick up item +KEY 17 "c" # Character info +KEY 18 "," # Pack item + +KEY 19 "b" # Bash +KEY 20 "a" # Aim weapon +KEY 21 "z" # Crouch +KEY 22 "v" # View skills +KEY 23 "u" # Use tool +KEY 24 "i" # Browse inventory + +KEY 25 "S" # Save game + +# More key: +# --------- + +KEY 29 " " # More / Scroll page + +# Item commands: +# -------------- + +KEY 30 "c" # Consume +KEY 31 "h" # Hold / Put held item +KEY 32 "d" # Drop +KEY 33 "t" # Throw +KEY 34 "l" # Loot +KEY 35 "e" # Equip +KEY 36 "p" # Put to pack + +# End of file. +# ------------ + +END \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/editcfg/levels.cfg Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,58 @@ +# +# This is level shemes definition file. +# ===================================== +# +# Understanding: +# -------------- +# +# LEVEL LevelID +# NAME LevelName - Level name. +# ROOM PlaceID RoomID - Number of place (1-10) and room to be put in that place. +# QUANTITY Quantity - How many times can this place be generated on particular level. Default 255. +# CONNECT PlaceIDx10 - List of places to connect to. If first number is zero -- there will be only one entrance, unless you use EASYDOOR. +# DOOR TileID - Tile to use as door in this place (0 for none). +# BACK TileID x10 - Tiles to fill the map area with before digging rooms. +# MAP BackNumber x16 - Fraktal seed. Uses numbers from BACK positions. +# ERODE Probability - Probability for fraktal tile to be destroyed. +# + +# Some sample levels: +# ------------------- + +LEVEL 1 # Space base + NAME "space base" + + BACK 32 32 # large tree + 32 # small tree + 32 # large bush + 32 # large bush + 32 # small bush + 32 # grass + 32 # grass + 32 # sand + 32 # water + + ERODE 0 + + + ROOM 1 0 # entrance + CONNECT 3 0 0 0 0 0 0 0 0 0 + QUANTITY 1 + DOOR 11 # stone + + ROOM 2 1 # corridor + CONNECT 2 3 0 0 4 4 4 0 0 0 + DOOR 11 # stone + + ROOM 3 2 # bend + CONNECT 2 4 0 0 0 0 0 0 0 0 + DOOR 83 + + ROOM 4 3 # small room + CONNECT 2 2 2 4 4 4 0 0 0 0 + DOOR 84 + +# End of file. +# ------------ + +END \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/editcfg/main.cfg Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,83 @@ +# +# This is main and temporary definitions file. +# ============================================ +# + +# Colors: +# ------- + +MSGCOLOR 2 # Default messages color. +SHDCOLOR 5 # Color of non visible parts of map. + +# Set color palette (remove this for non VGA drivers): +# ---------------------------------------------------- + +PALETTE + 00 00 00 # Black + 15 00 47 # Navy + 07 31 00 # Green + 00 31 31 # Cyan + 47 00 00 # Red + 31 23 31 # Purple + 31 23 00 # Brown + 39 39 39 # Grey + 23 23 23 # Dark + 31 31 63 # Blue + 31 47 00 # Lime + 07 47 47 # Light cyan + 63 07 00 # Light red + 63 39 00 # Yellow + 47 31 00 # Light brown + 63 63 63 # White + +# Load CFG files: +# --------------- + +#SHOW "@P////////////////" +#SHOW "@D_ __ __ __ " +#SHOW "@D(_/ |_\\ |_) ( . " +#SHOW "@D | .| |.| \\. ~|." +#SHOW "@D ' ' ' ' " +#SHOW "@P////////////////" +#SHOW "@D Yet Another " +#SHOW "@D Roguelike Game " + + +SHOW "" +SHOW " @o|" +SHOW " @O|" +SHOW "@o--@O-@P+@O-@o--" +SHOW " @O|" +SHOW " @o|" + +SHOW "@MYet Another Roguelike Game" +VERSION +SHOW "Reading configuration files@M:" +SHOW " @Mo@m Reading message strings@M..." +TEXT "messages.gz" +SHOW " @Mo@m Reading keys definitions@M..." +KEYS "keys.gz" +SHOW " @Mo@m Reading tiles definitions@M..." +TILES "tiles.gz" +SHOW " @Mo@m Reading room maps definitions@M..." +ROOMS "rooms.gz" +SHOW " @Mo@m Reading level shemes definitions@M..." +LEVELS "levels.gz" +SHOW " @Mo@m Reading items definitions@M..." +ITEMS "items.gz" +SHOW " @Mo@m Reading creatures definitions@M..." +MONSTERS "monsters.gz" +SHOW "Initialization complete@M." + +# Player character defaults: +# -------------------------- + +ID "Sheep" # Players name +LEVEL 1 # Level sheme +SCROLL 8 # How far from screen edge to scroll. + + +# End of file. +# ------------ + +END \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/editcfg/messages.cfg Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,145 @@ +# +# Messages and other texts definition file. +# ========================================= +# +# Special characters: +# ------------------- +# +# Colors: +# @d - Black @D - Dark +# @b - Navy @B - Blue +# @g - Khaki @G - Green +# @c - Cyan @C - Light cyan +# @r - Red @R - Light red +# @p - Purple @P - Yellow +# @o - Brown @O - Orange +# @w - Grey @W - White +# @m - Default @M - Default bold +# +# Other: +# @n - New line. @v - Variable. +# @N - No new line, no message stacking. +# @@ - '@' character. +# +# Status: +# @v - ID +# @1,@2,...,@0 - Stats +# + +# Status lines (no more than 256 characters and 5 lines!): +# -------------------------------------------------------- + +STAT "@P/////////// @DStatus@P ///////////" +STAT " @rID: @R@v@r Sta:@R@5@r Sta:@R@8" +STAT " @rHP: @R@1/@2@r Sta:@R@6@r Sta:@R@9" +STAT " @rPW: @R@3/@4@r Sta:@R@7@r Sta:@R@0" +STAT "@P////////// @DMessages@P //////////" + +# Help text (no more than MAXLONGSTRING lines!): +# ----------------------------------- + +HELP "Keys:" +HELP " @MNumPad@m - Walk;" +HELP " @M.@m) Wait;" +HELP " @Mz@m) Crouch;" +HELP " @M>@m) Enter;" +HELP " @Mo@m) Operate;" +HELP " @Mb@m) Bash;" +HELP " @Ma@m) Aim weapon;" +HELP " @Me@m) Browse equipment;" +HELP " @Mi@m) Browse pack;" +HELP " @M;@m) Pick up an item;" +HELP " @M,@m) Put an item into pack;" +HELP " @Mc@m) Character info;" +HELP " @Mv@m) View skills;" +HELP " @Ml@m) Look;" +HELP " @MS@m) Save game;" +HELP " @MQ@m) Quit;" + +# Death text (no more...) +# ----------------------- + +DEATH "@R d' @D. @R`b. @R(. @D. @R(" +DEATH "@R Yb @wd8b @Rd^~@D,... @R`P @wd8b@R b" +DEATH "@R `88.@wYP^.od888888bo.@w^YP@R,8b" +DEATH "@R Y8b@w`'d888888888888b@w`'@Rd8P" +DEATH "@R ) d88 @wd88P^`Y88P'^Y88b @RYP' " +DEATH "@Rd' ,88'@w;8P' `88' @w`Y8: @R` (" +DEATH "@RP d8P @wd8' YP @w`8b @R) `" +DEATH "@R` ,88b @w88 @B+ @wdb @B+ @w88 @Rd " +DEATH "@R d888.@wY8. P8 @w,8P@R,d' d" +DEATH "@R 8888b@w`8bo..,d'Pb..,od8'@Rd8 ,8" +DEATH "@R( `8888b-@w`^Y888,@D.@w888P^'@R-d88bd8" +DEATH "@R ) Y888'@wd8b@R,@D;@w888888:@R.@wd8b@R`88888" +DEATH "@Rd: :888.@wY8'@R/@wd888888b@R\\@w`8P@R,88888" +DEATH "@R8b.d888bood.@wYP@R.@wYP@R.@wYP@R,bood88888" +DEATH "@R88888888888booboodood888888888" + +# Main menu text (no more...) +# ----------------------- + +MENU "@P//////////////////////////////" +MENU "@D888888888888888888888888888888" +MENU "@D8b P' 8b `88b _`Y8' d88" +MENU "@D88. d88 ^ 888 _d8 C~~888" +MENU "@D8888 8~8 . 8~8 . Y~b , 8~8" +MENU "@D8888,o888,o8o888,obod8888,o888" +MENU "@P//////////////////////////////" +MENU " @Mn@m) @MNew game@m;" +MENU " @Ml@m) @MLoad saved game@m;" +MENU " @Mq@m) @MQuit@m;" + +# Messages: +# --------- + +MSG 0 "@NPress '@M?@m' for help." +MSG 1 "@N@MAim where?" +MSG 2 "You hit @M@v@m. " +MSG 3 "You demolish @M@v@m." +MSG 4 "@N@MLook where?" +MSG 5 "There is @M@v@m here." +MSG 6 "@N@MOperate what?" +MSG 7 "Nothing to operate." +MSG 8 "Nowhere to enter here." +MSG 9 "There is no item." +MSG 10 "@NCancelled." +MSG 11 "Time passes..." +MSG 12 "Entering @M@v@m now..." +MSG 13 "You see @M@v@m lying here." +MSG 14 "You can't see anything there." +MSG 15 "You put @M@v@m into @M@1@m." +MSG 16 "@N@MWhich item?" +MSG 17 "You examine @M@v@m." +MSG 18 "There is no room." +MSG 19 "Strike @Mspace@m for more..." +MSG 20 "You equip @M@v@m." +MSG 21 "@N@MBash what?" +MSG 22 "You are slowed down." +MSG 23 "Ouch! It burns." +MSG 24 "You swim." +MSG 25 "You crawl." +MSG 26 "You crouch." +MSG 27 "You stand up." +MSG 28 "Stand up first." +MSG 29 "Contents of @M@v@m:" +MSG 30 " @M@1@m) @M@v@m;" +MSG 31 "You have no pack!" +MSG 32 "You need free hands!" +MSG 33 "It weights @M@v@m unit@s." +MSG 34 "Saving game..." +MSG 35 "Please enter your @MID@m:" + +# Item commands: +# -------------- + +MSG 40 " @Ml@m) @Mloot contents@m;" +MSG 41 " @Mh@m) @Mhold@m;" +MSG 42 " @Mh@m) @Mput held item in@m;" +MSG 43 " @Md@m) @Mdrop@m;" +MSG 44 " @Me@m) @Mequip@m;" +MSG 45 " @Mp@m) @Mput into pack@m;" + +# End of file. +# ------------ + +END
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/editcfg/monsters.cfg Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,37 @@ +# +# This is monsters definition file. +# ================================= +# +# +# Understanding: +# -------------- +# +# MONSTER MonsterID - Begining of an entry. +# NAME MonsterName - Name of the monster. +# LOOKS Character Color - Looks. +# HPMAX HpMax - Maximum number of hit points. +# SPEED Speed - Monster speed. +# +# +# Special 'our hero' creature: +# ---------------------------- + +MONSTER 0 + NAME "player character" + LOOKS "@" 15 + HPMAX 100 + SPEED 30 + +# Testing creatures: +# ------------------ + +MONSTER 1 + NAME "dummy droid" + LOOKS "d" 9 + HPMAX 100 + SPEED 10 + +# End of file. +# ------------ + +END \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/editcfg/rooms.cfg Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,139 @@ +# +# This is rooms definition file. +# ============================== +# +# Understandig: +# ------------- +# +# CHAR Character TileID - Character represents that tile. +# ROOM RoomID MapString x16 - Rooms map. Each string must be 16 characters long. +# EASYDOOR - Put door everywhere possible. +# + +# Special tiles: +# -------------- + +CHAR " " 0 # Empty +CHAR "x" 1 # Soft edge, door possible +CHAR "X" 2 # Hard edge, no door + +# Floors: +# ------- + +CHAR "," 15 # Grass +CHAR ":" 12 # Ground +CHAR ";" 11 # Metal floor +CHAR "'" 13 # Sand + +# Walls: +# ------ + +CHAR "%" 36 # Brick wall +CHAR "@" 35 # Wooden wall + +# Others: +# ------- + +CHAR "*" 66 # Fountain +CHAR "d" 81 # Closed wooden door +CHAR "0" 3 # Entrance + +# Special starting room: +# ---------------------- + +ROOM 0 " " + " " + " " + " " + " " + " " + " x " + " x0x " + " x " + " " + " " + " " + " " + " " + " " + " " +EASYDOOR + +# Other rooms; +# ------------ + +# Corridor +ROOM 1 " " + " " + " " + " " + " XxX " + " x;x " + " X;X " + " XX;XX " + " X;X " + " x;x " + " XxX " + " " + " " + " " + " " + " " +EASYDOOR + +# Corridor bend +ROOM 2 " " + " " + " " + " " + " " + " XxX " + " x;x " + " XxX " + " " + " " + " " + " " + " " + " " + " " + " " +EASYDOOR + +# Room +ROOM 3 "XxxxxxxxxxxxxxxX" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "x;;;;;;;;;;;;;;x" + "XxxxxxxxxxxxxxxX" + +# Room +ROOM 4 " " + " " + " " + " XxxxxxX " + " x;;;;;x " + " x;;;;;x " + " x;;;;;x " + " x;;;;;x " + " x;;;;;x " + " x;;;;;x " + " x;;;;;x " + " XxxxxxX " + " " + " " + " " + " " + +END \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/editcfg/tiles.cfg Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,565 @@ +# +# This is tiles definition file. +# ============================== +# +# Understanding: +# -------------- +# +# TILE TileID - Number of the tile (max 127). +# NAME TileName - Name of the tile (max 36 letters). +# LOOKS Character Color - Character and color to represent the tile. +# CHANGETO TileID - What tile to change to when operating. +# DESTROYTO TileID - What tile to change when destroyed (0 for undestructible). +# VISION Shade - How much does it block light (Default 5, max 100, >=30 drops shadow). +# MOVE MoveCost - Move cost of a tile. 100 for block. +# SWIM - Liquid - can swim through it. +# BURN - Burns. +# UPPER - Upper ground. +# ENTER - Can enter it. +# EXIT - Can exit thru it. +# OPERATE - Operational. +# SMARTDOOR - Changes character to "-" when appropriate. +# FRAGILE - Bash it on move, easy to bash. +# ITEM - An item can lie there. +# + +# Special tiles: +# -------------- + +TILE 0 + NAME "nothing" + LOOKS " " 7 + + VISION 100 + MOVE 100 + DESTROYTO 0 + +TILE 1 + NAME "soft edge" + LOOKS " " 7 + MOVE 100 + DESTROYTO 0 + +TILE 2 + NAME "hard edge" + LOOKS " " 7 + MOVE 100 + DESTROYTO 0 + +TILE 3 + NAME "a landing site" + LOOKS "0" 9 + MOVE 30 + DESTROYTO 0 + VISION 50 + ENTER + +TILE 4 + NAME "an exit ramp" + LOOKS "0" 7 + MOVE 30 + DESTROYTO 0 + ENTER + +# Floors: +# ------- + +TILE 10 + NAME "a piece of stone floor" + LOOKS "." 7 + MOVE 30 + DESTROYTO 0 + ITEM + +TILE 11 + NAME "a piece of metal floor" + LOOKS "." 11 + MOVE 30 + DESTROYTO 0 + ITEM + +TILE 12 + NAME "some ground" + LOOKS "." 14 + MOVE 30 + DESTROYTO 0 + ITEM + +TILE 13 + NAME "some sand" + LOOKS "." 13 + MOVE 30 + DESTROYTO 0 + ITEM + +TILE 14 + NAME "some snow" + LOOKS "." 15 + MOVE 30 + DESTROYTO 12 + ITEM + +TILE 15 + NAME "a patch of grass" + LOOKS "." 10 + MOVE 30 +# DESTROYTO 12 + ITEM + +TILE 16 + NAME "a bloody stain" + LOOKS "." 12 + MOVE 30 + DESTROYTO 0 + ITEM + +# Unusual floors: +# --------------- + +TILE 21 + NAME "a pool of water" + LOOKS "=" 9 + MOVE 50 + DESTROYTO 0 + SWIM + +TILE 22 + NAME "a pool of lava" + LOOKS "=" 12 + MOVE 50 + DESTROYTO 67 + BURN + +TILE 23 + NAME "a pool of slime" + LOOKS "=" 10 + MOVE 50 + DESTROYTO 0 + SWIM + +TILE 24 + NAME "a pool of black mass" + LOOKS "=" 8 + MOVE 50 + DESTROYTO 0 + BURN + +TILE 25 + NAME "an ice sheet" + LOOKS "=" 15 + MOVE 50 + DESTROYTO 21 + ITEM + +TILE 26 + NAME "a quicksand" + LOOKS "=" 13 + MOVE 50 + DESTROYTO 0 + SWIM + +TILE 27 + NAME "a metal grate" + LOOKS "=" 3 + MOVE 30 + DESTROYTO 0 + +# Walls: +# ------ + +TILE 30 + NAME "a solid rock" + LOOKS "#" 8 + MOVE 100 + DESTROYTO 50 + + VISION 100 + DROPITEM 11 # Pebble + +TILE 31 + NAME "a stone wall" + LOOKS "#" 7 + MOVE 100 + DESTROYTO 50 + + VISION 100 + DROPITEM 11 # Pebble + +TILE 32 + NAME "a metal wall" + LOOKS "#" 3 + MOVE 100 + DESTROYTO 51 + + VISION 100 + DROPITEM 10 # Junk + +TILE 33 + NAME "a glowing metal wall" + LOOKS "#" 11 + MOVE 100 + DESTROYTO 51 + + VISION 100 + +TILE 34 + NAME "an ice wall" + LOOKS "#" 15 + MOVE 100 + DESTROYTO 53 + + VISION 100 + +TILE 35 + NAME "a wooden wall" + LOOKS "#" 14 + MOVE 100 + DESTROYTO 57 + + VISION 100 + DROPITEM 12 # Stick + +TILE 36 + NAME "a brick wall" + LOOKS "#" 4 + MOVE 100 + DESTROYTO 52 + + VISION 100 + + +TILE 37 + NAME "a wall with some ivy" + LOOKS "#" 10 + MOVE 100 + DESTROYTO 50 + + VISION 100 + +TILE 38 + NAME "a wall of soil" + LOOKS "#" 6 + MOVE 100 + DESTROYTO 55 + + VISION 100 + +TILE 39 + NAME "a wall of strange mass" + LOOKS "#" 13 + MOVE 100 + DESTROYTO 12 + + VISION 100 + +# Demolished & upper ground: +# -------------------------- + +TILE 50 + NAME "a pile of rubble" + LOOKS ":" 7 + UPPER + VISION 30 + MOVE 50 + DESTROYTO 10 + +TILE 51 + NAME "a pile of junk" + LOOKS ":" 11 + MOVE 50 + DESTROYTO 11 + VISION 30 + UPPER + +TILE 52 + NAME "a pile of bricks" + LOOKS ":" 12 + MOVE 50 + DESTROYTO 12 + VISION 30 + UPPER + +TILE 53 + NAME "a snow dune" + LOOKS ":" 15 + MOVE 50 + DESTROYTO 14 + VISION 20 + UPPER + +TILE 54 + NAME "a sand dune" + LOOKS ":" 13 + MOVE 50 + DESTROYTO 13 + VISION 20 + UPPER + +TILE 55 + NAME "a mound" + LOOKS ":" 14 + MOVE 50 + DESTROYTO 12 + VISION 20 + UPPER + +TILE 56 + NAME "a thicket" + LOOKS ":" 10 + MOVE 50 + DESTROYTO 15 + VISION 10 + + FRAGILE + +TILE 57 + NAME "a pile of wood" + LOOKS ":" 6 + MOVE 50 + DESTROYTO 12 + VISION 30 + UPPER + +# Large obstacles: +# ---------------- + +TILE 60 + NAME "a large tree" + LOOKS "*" 10 + MOVE 100 + DESTROYTO 61 + VISION 70 + + +TILE 61 + NAME "a small tree" + LOOKS "*" 2 + MOVE 100 + DESTROYTO 70 + + VISION 40 + +TILE 62 + NAME "a boulder" + LOOKS "*" 8 + MOVE 100 + DESTROYTO 50 + + VISION 40 + +TILE 63 + NAME "a large machine" + LOOKS "*" 3 + VISION 70 + MOVE 100 + DESTROYTO 51 + + +TILE 64 + NAME "a large crystal" + LOOKS "*" 15 + MOVE 100 + DESTROYTO 0 + + VISION 30 + +TILE 65 + NAME "a statue" + LOOKS "*" 7 + MOVE 100 + DESTROYTO 50 + + +TILE 66 + NAME "a fountain" + LOOKS "*" 9 + MOVE 70 + DESTROYTO 0 + SWIM + VISION 30 + + +TILE 67 + NAME "a large flame" + LOOKS "*" 12 + MOVE 70 + DESTROYTO 0 + VISION 30 + BURN + +# Small obstacles: +# ---------------- + +TILE 70 + NAME "a large bush" + LOOKS "+" 10 + VISION 40 + + MOVE 100 + DESTROYTO 71 + FRAGILE + +TILE 71 + NAME "a small bush" + LOOKS "+" 2 + MOVE 100 + DESTROYTO 56 + FRAGILE + VISION 20 + +TILE 73 + NAME "a small machine" + LOOKS "+" 3 + MOVE 100 + DESTROYTO 51 + VISION 100 + + +TILE 74 + NAME "a small crystal" + LOOKS "+" 15 + MOVE 50 + DESTROYTO 0 + VISION 100 + + +TILE 75 + NAME "a tombstone" + LOOKS "+" 7 + MOVE 50 + DESTROYTO 50 + VISION 100 + + +TILE 76 + NAME "a terminal" + LOOKS "+" 9 + MOVE 100 + DESTROYTO 51 + VISION 100 + OPERATE + +# Doors: +# ------ + +TILE 80 + NAME "an opened wooden door" + LOOKS "\\" 6 + CHANGETO 81 + MOVE 30 + DESTROYTO 57 + OPERATE + DROPITEM 12 # Stick + +TILE 81 + NAME "a closed wooden door" + LOOKS "|" 6 + CHANGETO 80 + MOVE 100 + DESTROYTO 57 + + VISION 100 + OPERATE SMARTDOOR + DROPITEM 12 # Stick + +TILE 82 + NAME "a locked wooden door" + LOOKS "|" 6 + CHANGETO 80 + MOVE 100 + DESTROYTO 57 + + VISION 100 + OPERATE SMARTDOOR + DROPITEM 12 # Stick + +TILE 83 + NAME "an opened metal door" + LOOKS "\\" 3 + CHANGETO 84 + MOVE 30 + DESTROYTO 51 + OPERATE + DROPITEM 10 # Junk + +TILE 84 + NAME "a closed metal door" + LOOKS "|" 3 + CHANGETO 83 + MOVE 100 + DESTROYTO 51 + + VISION 100 + OPERATE SMARTDOOR + DROPITEM 10 # Junk + +TILE 85 + NAME "a locked metal door" + LOOKS "|" 3 + CHANGETO 83 + MOVE 100 + DESTROYTO 51 + + VISION 100 + OPERATE SMARTDOOR + DROPITEM 10 # Junk + +TILE 86 + NAME "an opened gate" + LOOKS "\\" 8 + CHANGETO 87 + MOVE 30 + DESTROYTO 51 + OPERATE + DROPITEM 10 # Junk + +TILE 87 + NAME "a closed gate" + LOOKS "|" 8 + CHANGETO 86 + MOVE 100 + DESTROYTO 51 + OPERATE SMARTDOOR + DROPITEM 10 # Junk + +TILE 88 + NAME "a locked gate" + LOOKS "|" 8 + CHANGETO 86 + MOVE 100 + DESTROYTO 51 + OPERATE SMARTDOOR + DROPITEM 10 # Junk + +TILE 89 + NAME "an opened airlock" + LOOKS "\\" 4 + CHANGETO 90 + MOVE 30 + DESTROYTO 51 + OPERATE + +TILE 90 + NAME "a closed airlock" + LOOKS "|" 4 + CHANGETO 89 + MOVE 100 + DESTROYTO 51 + VISION 100 + OPERATE SMARTDOOR + DROPITEM 10 # Junk + +TILE 91 + NAME "a ed airlock" + LOOKS "|" 4 + CHANGETO 89 + MOVE 100 + DESTROYTO 51 + VISION 100 + OPERATE SMARTDOOR + DROPITEM 10 # Junk + +# End of file. +# ------------ + +END \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/global.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,348 @@ +{ Global variables, constants, types and functions. } + +UNIT Global; + +INTERFACE + + +CONST VERSION='0.09'; + + DATADIR='.\data\'; + MAINCFG='main.gz'; + + { map flags } + MAP_VISIBLE=0; { visible } + MAP_EXPLORED=1; { explored } + + { tile flags } + TILE_EXIT=0; { can be exited } + TILE_ENTER=1; { can be entered } + TILE_OPERATE=2; { can be operated } + TILE_SMARTDOOR=3; {changes character to '-' when wall nearby} + TILE_ITEM=4; { an item can be lying here } + TILE_FRAGILE=5; { bash down automatically } + TILE_BURN=6; { burns } + TILE_SWIM=7; { you have to swim } + TILE_UPPER=8; { upper ground } + + { item flags } + ITEM_MULTIPLE=0; + ITEM_KNOWN=1; + ITEM_EMPTY=2; + + { room flags } + ROOM_EASYDOOR=0; + ROOM_UNIQUE=1; + + { slot flags } + SLOT_KNOWN=0; + + { item classes } + CLASS_HAND=7; + CLASS_GUN =8; + CLASS_AMMO=9; + CLASS_HEAD=6; + CLASS_BODY=5; + CLASS_BACK=11; + CLASS_TOOL=1; + CLASS_FOOD=3; + + LIGHT_EMPTY=0; { light values } + LIGHT_LIT=1; + LIGHT_DARK=2; + + CMDNOTHING=0; { commands } + CMDSOUTHWEST=1; + CMDSOUTH=2; + CMDSOUTHEAST=3; + CMDWEST=4; + CMDHERE=5; + CMDEAST=6; + CMDNORTHWEST=7; + CMDNORTH=8; + CMDNORTHEAST=9; + + CMDQUIT=10; + CMDOPERATE=11; + CMDLOOK=12; + CMDHELP=13; + CMDENTER=14; + CMDEXAM=15; + CMDPICKUP=16; + CMDINFO=17; + CMDPACK=18; + + CMDBASH=19; + CMDAIM=20; + CMDCROUCH=21; + CMDSKILLS=22; + CMDTOOL=23; + CMDINVEN=24; + CMDSAVE=25; + + CMDMORE=29; + + CMDCONSUME=30; + CMDUPINAIR=31; + CMDDROP=32; + CMDTHROW=33; + CMDLOOT=34; + CMDEQUIP=35; + CMDPUTTOPACK=36; + + INV_HELD=0; + INV_PACK=1; + INV_WEAR=2; + + DIRX: ARRAY[0..9] OF INTEGER = (0,-1,0,1,-1,0,1,-1,0,1); { directions } + DIRY: ARRAY[0..9] OF INTEGER = (0,1,1,1,0,0,0,-1,-1,-1); + + MAXCMD=64; { maximum number of commands } + MAXMSG=64; { maximum number of messages } + + MAXLEVELS=32; { maximum number of level shemes } + MAXSKILLS=16; + MAXSLOT=2; { max number of slots in inventory } + MAXROOMS=10; { max number of rooms per level } + + MAPXSIZE=24; { map size } + MAPYSIZE=63; + + MAXLONGSTRING=20; + + MARGIN:BYTE=7; { center how far from edge } + + PILEITEM=1; { Special 'multiple items' item } + +TYPE Bits=SET OF 0..7; + Flags= SET OF 0..15; + + LongString=ARRAY[0..MAXLONGSTRING] OF STRING[47]; + + TileDef=^TileDefRec; + TileDefRec=RECORD + id: BYTE; { tile id } + nam: STRING[36]; { tile name } + chn: BYTE; { change to } + chr: CHAR; { character } + atr: BYTE; { attribute } + flg: Flags; { flags } + dst: BYTE; { destroy to } + vis: BYTE; { vision blocking } + drp: BYTE; { item to drop when destroyed } + mov: BYTE; { move cost } + next: TileDef; { next in list } + END; + + ItemDef=^ItemDefRec; + ItemDefRec=RECORD + id: WORD; { item id } + nam: STRING[36]; { item name } + chr: CHAR; { character } + atr: BYTE; { attribute } + flg: Bits; { flags } + dsc: STRING; { item description } + unk: BYTE; { unknown looks } + qnt: WORD; { quantity/quality } + eqp: BYTE; { equip slot } + wgt: BYTE; { item base weight } + next: ItemDef; { next in list } + END; + + pItem=^ItemRec; + ItemSlot=^pItem; + ItemRec=RECORD + def: ItemDef; { item type } + qnt: WORD; { quantity/quality } + flg: Bits; { flags } + con: pItem; { item contents } + next: pItem; { next item in list } + END; + + CreatDef=^CreatDefRec; + CreatDefRec=RECORD + id: WORD; + nam: STRING[36]; + chr: CHAR; + atr: BYTE; + hp: INTEGER; + spd: INTEGER; + next: CreatDef; + END; + + pCreat=^CreatRec; + CreatRec=RECORD { Creature record } + def: CreatDef; { Creature type } + x,y: INTEGER; { Position on map } + mov: LONGINT; { last move time } + hp: INTEGER; { hp left } + next: pCreat; { next creature in list } + END; + + pMap=^MapRec; + MapRec=RECORD + ter: TileDef; { terrain } + slt: pItem; { item slot } + crt: pCreat; { creature } + flg: Bits; { flags } + END; + + tMappa=ARRAY[0..MAPXSIZE,0..MAPYSIZE] OF MapRec; + + pRoom=^RoomRec; + RoomRec=RECORD + id: BYTE; { room id } + map: ARRAY[0..15,0..15] OF BYTE; { room map } + dor: BYTE; { door tile id } + flg: Bits; { flags } + next: pRoom; { next in list } + END; + + PlaceRec=RECORD + rom: BYTE; { room id } + con: ARRAY[1..MAXROOMS] OF BYTE; { places to connect to } + flg: Bits; { flags } + dor: BYTE; + qnt: BYTE; + END; + Places=ARRAY[1..MAXROOMS] OF PlaceRec; + + pLevel=^LevelRec; + LevelRec=RECORD + id: BYTE; { level id } + name: STRING[36]; { level name } + back: ARRAY[0..9] OF BYTE; { background tiles } + map: ARRAY[0..3,0..3] OF BYTE; { map seed } + erosion: BYTE; { erosion } + next: pLevel; { next in list } + rooms: Places; + END; + + SkillRec=RECORD + name: STRING[36]; + val: BYTE; + END; + + PlayerRec=RECORD + id: STRING[8]; { player name } + stats: ARRAY[0..9] OF INTEGER; { stats } + skl: ARRAY[1..MAXSKILLS] OF SkillRec;{ skills } + inv: ARRAY[0..MAXSLOT] OF pItem; { inventory } + lev: BYTE; { level sheme } + intown: BOOLEAN; { is pc in town } + crouch: BOOLEAN; { is pc crouching } + END; + +VAR mappa: ^tMappa; + cmd: ARRAY[0..MAXCMD] OF CHAR; + msgs: ARRAY[0..MAXMSG] OF STRING[47]; + pc: PlayerRec; + tilelist: TileDef; + itemlist: ItemDef; + roomlist: pRoom; + levellist: pLevel; + monsterlist: CreatDef; + allmonsters: pCreat; + playchr: pCreat; + + stat_string: STRING; + help_string: LongString; + death_string: LongString; + menu_string: LongString; + + shadecolor: BYTE; + gametime: LONGINT; + +FUNCTION InMap(x,y: INTEGER): BOOLEAN; +FUNCTION GetMap(x,y: INTEGER): pMap; +FUNCTION FindTile(id: BYTE): TileDef; +FUNCTION FindItem(id: BYTE): ItemDef; +FUNCTION FindRoom(id:BYTE): pRoom; +FUNCTION FindLevel(id:BYTE): pLevel; +FUNCTION FindMonster(id: WORD): CreatDef; + +IMPLEMENTATION + +FUNCTION InMap(x,y: INTEGER): BOOLEAN; +BEGIN + InMap:=NOT((x<0)OR(x>MAPXSIZE)OR(y<0)OR(y>MAPYSIZE)); +END; + +FUNCTION GetMap(x,y: INTEGER): pMap; +BEGIN + GetMap:=NIL; + IF (NOT InMap(x,y)) OR (mappa=NIL) THEN Exit; + GetMap:=@mappa^[x,y]; +END; + +FUNCTION FindItem(id: BYTE): ItemDef; +VAR p: ItemDef; +BEGIN + p:=itemlist; + REPEAT + IF p^.id=id THEN BEGIN + FindItem:=p; + Exit; + END; + p:=p^.next; + UNTIL p=NIL; + FindItem:=itemlist; +END; + +FUNCTION FindRoom(id:BYTE): pRoom; +VAR p: pRoom; +BEGIN + p:=roomlist; + REPEAT + IF p^.id=id THEN BEGIN + FindRoom:=p; + Exit; + END; + p:=p^.next; + UNTIL p=NIL; + FindRoom:=roomlist; +END; + +FUNCTION FindLevel(id:BYTE): pLevel; +VAR p: pLevel; +BEGIN + p:=levellist; + REPEAT + IF p^.id=id THEN BEGIN + FindLevel:=p; + Exit; + END; + p:=p^.next; + UNTIL p=NIL; + FindLevel:=levellist; +END; + +FUNCTION FindTile(id: BYTE): TileDef; +VAR p: TileDef; +BEGIN + p:=tilelist; + REPEAT + IF p^.id=id THEN BEGIN + FindTile:=p; + Exit; + END; + p:=p^.next; + UNTIL p=NIL; + FindTile:=tilelist; +END; + +FUNCTION FindMonster(id: WORD): CreatDef; +VAR p: CreatDef; +BEGIN + p:=monsterlist; + REPEAT + IF p^.id=id THEN BEGIN + FindMonster:=p; + Exit; + END; + p:=p^.next; + UNTIL p=NIL; + FindMonster:=monsterlist; +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/items.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,410 @@ +{ Items handling routines. } + +UNIT Items; + +INTERFACE + +USES Global; + +FUNCTION GetItemWeight(what: ItemSlot): INTEGER; { Counts the weight of an item. } +FUNCTION IsInThere(what,where: ItemSlot):BOOLEAN; { Checks if item WHAT is somwhere inside item WHERE. } +PROCEDURE GetItemLooks(VAR a:BYTE;VAR c:CHAR;what:ItemSlot); { Sets A and C to fit items looks. } +FUNCTION GetItemDesc(what: ItemSlot): STRING; { Returns item description. } +FUNCTION ItemName(what: ItemSlot): STRING; { Returns the name of an item. } +PROCEDURE ShowItem(what: ItemSlot); { Tells what kind of item is there. } + +FUNCTION GenerateItem(id:BYTE):pItem; { Creates a new item from definitions. } +PROCEDURE DestroyItem(what: ItemSlot); { Destroys an item. } +PROCEDURE MoveInto(what,where: ItemSlot); { Tries to put item from WHAT into container in slot WHERE. } +PROCEDURE MoveItem(what,where: ItemSlot); { Tries to put item from WHAT into slot WHERE. } +PROCEDURE DropItem(what,where: ItemSlot); { Drops item from WHAT into slot WHERE, creating a pile if needed. } +PROCEDURE PutToPack(what: ItemSlot); { Tries to put an item into pack. } + +FUNCTION ListItems(where: ItemSlot):ItemSlot; { Lists all items in the container and picks one. } +PROCEDURE SelectItem(what: ItemSlot); { Shows item description,asks for action and performs it. } +PROCEDURE CheckPile(where: ItemSlot); { Destroys a pile if itsn't needed anymore. } +PROCEDURE ExamInv; { Displays equipment. } + +IMPLEMENTATION + +USES Console; + +TYPE pStack=^StackRec; + StackRec=RECORD + slt: pItem; + next: pStack; + END; + +VAR stack: pStack; + +{ ------------------------------------------- Item information ---------- } + +PROCEDURE StackPush(what: pItem); { Pushes an item entry on stack. } +VAR tmp: pStack; +BEGIN + New(tmp); + tmp^.slt:=what; + tmp^.next:=stack; + stack:=tmp; +END; + +PROCEDURE StackPop(VAR what: pItem); { Pops an item entry from stack. } +VAR tmp: pStack; +BEGIN + IF stack=NIL THEN Exit; + what:=stack^.slt; + tmp:=stack; + stack:=stack^.next; + Dispose(tmp); +END; + + +FUNCTION GetItemWeight(what: ItemSlot): INTEGER; { Counts the weight of an item. } +VAR weight: INTEGER; + p: pItem; +BEGIN + stack:=NIL; { The stack is empty. } + weight:=what^^.def^.wgt*what^^.qnt; { Base weight. } + StackPush(what^^.con); { Now we search all the tree. } + REPEAT + StackPop(p); + WHILE p<>NIL DO BEGIN + Inc(weight,p^.def^.wgt*p^.qnt); + IF p^.con<>NIL THEN StackPush(p^.con); + p:=p^.next; + END; + UNTIL p=NIL; + GetItemWeight:=weight; +END; + +FUNCTION IsInThere(what,where: ItemSlot):BOOLEAN; { Checks if item WHAT is somwhere inside item WHERE. } +VAR p: pItem; +BEGIN + IsInThere:=FALSE; + stack:=NIL; + StackPush(where^); + REPEAT + StackPop(p); + WHILE p<>NIL DO BEGIN + IF p=what^ THEN IsInThere:=TRUE; + IF p^.con<>NIL THEN StackPush(p^.con); + p:=p^.next; + END; + UNTIL p=NIL; +END; + +PROCEDURE GetItemLooks(VAR a:BYTE;VAR c:CHAR;what:ItemSlot); { Sets A and C to fit items looks. } +VAR tmp: ItemDef; +BEGIN + IF (SLOT_KNOWN IN what^^.flg) THEN tmp:=what^^.def + ELSE tmp:=FindItem(what^^.def^.unk); + c:=tmp^.chr; + a:=tmp^.atr; +END; + +FUNCTION GetItemDesc(what: ItemSlot): STRING; { Returns item description. } +BEGIN + IF (SLOT_KNOWN IN what^^.flg)OR(what^^.def^.unk=0) THEN { If item is known -- we return its description. } + GetItemDesc:=what^^.def^.dsc + ELSE GetItemDesc:=FindItem(what^^.def^.unk)^.dsc; { But if not, we return description of item type. } +END; + +FUNCTION ItemName(what: ItemSlot): STRING; { Returns the name of an item. } +VAR s: STRING; +BEGIN + ItemName:=''; + IF (what^=NIL) THEN BEGIN { If there is nothing, we return 'nothing'. } + ItemName:=FindItem(0)^.nam; + Exit; + END; + + IF (SLOT_KNOWN IN what^^.flg) THEN s:=what^^.def^.nam { If item is known, we return its real name. } + ELSE s:=FindItem(what^^.def^.unk)^.nam; + + { When there are many items of the same kind, we tell how many. } + IF (ITEM_MULTIPLE IN what^^.def^.flg) AND (what^^.qnt>1) THEN + s:=Replace(Plural(s),'@a',Num(what^^.qnt)) + ELSE BEGIN { Elsewhen we add 'a' or 'an'. } + s:=Replace(s,'@a a','an a'); + s:=Replace(s,'@a e','an e'); + s:=Replace(s,'@a i','an i'); + s:=Replace(s,'@a o','an o'); + s:=Replace(s,'@a u','an u'); + s:=Replace(s,'@a ' ,'a '); + s:=Replace(s,'@a' ,'a'); + s:=Replace(s,'@s',''); + END; + ItemName:=s; +END; + +PROCEDURE ShowItem(what: ItemSlot); { Tells what kind of item is there. } +BEGIN + IF what^=NIL THEN Exit; { If there is nothing -- we won't bother. } + Msg(Replace(msgs[13],'@v',ItemName(what))); +END; + +{ ------------------------------------------- Item moving and creation -- } + +FUNCTION GenerateItem(id:BYTE):pItem; { Creates a new item from definitions. } +VAR item: ItemDef; + tmp: pItem; +BEGIN + New(tmp); { We make room for item. } + item:=FindItem(id); { We find according definitions. } + tmp^.def:=item; { We fill in all data necessary. } + tmp^.qnt:=item^.qnt+Random(item^.qnt); + tmp^.flg:=[]; + tmp^.con:=NIL; + tmp^.next:=NIL; + IF (ITEM_KNOWN IN item^.flg) THEN tmp^.flg:=tmp^.flg+[SLOT_KNOWN]; + GenerateItem:=tmp; { And we have brand new item. } +END; + +PROCEDURE DestroyItem(what: ItemSlot); { Destroys an item. } +VAR tmp: pItem; +BEGIN + tmp:=what^; { We take item from any container it may be in. } + what^:=tmp^.next; { We update this container's list of items. } + Dispose(tmp); { And we relase memory. } +END; + +PROCEDURE MoveInto(what,where: ItemSlot); { Tries to put item from WHAT into container in slot WHERE. } +VAR tmp: pItem; +BEGIN + IF IsInThere(where,what) THEN Exit; { We dont want to put something into itself! } + tmp:=what^; { Now, we take item from any container it may be in. } + what^:=tmp^.next; { We update this container's list of items. } + tmp^.next:=where^^.con; { We put all items from WHERE behind our item. } + where^^.con:=tmp; { We put our item into item in slot WHERE. } +END; + +PROCEDURE MoveItem(what,where: ItemSlot); { Tries to put item from WHAT into slot WHERE. } +VAR tmp: pItem; +BEGIN + IF where^<>NIL THEN Exit; { Is there something already? } + tmp:=what^; { Now, we take item from any container it may be in. } + what^:=tmp^.next; { We update this container's list of items. } + tmp^.next:=NIL; { Our item is the only one here. } + where^:=tmp; { We put our item into slot WHERE. } +END; + +PROCEDURE DropItem(what,where: ItemSlot); { Drops item from WHAT into slot WHERE, creating a pile if needed. } +VAR tmp: ItemSlot; + p: pItem; +BEGIN + IF where^=NIL THEN BEGIN { If WHERE is empty, we simply put our item there. } + MoveItem(what,where); + Exit; + END; + + IF where^^.def^.id=PILEITEM THEN BEGIN { If there is a pile already, we just add our item to the pile. } + MoveInto(what,where) + END ELSE BEGIN { If there is an item already... } + New(tmp); { We need 'third hand'. } + tmp^:=NIL; + MoveItem(where,tmp); { We pick the item from the floor. } + p:=GenerateItem(PILEITEM); { Then we create a pile... } + MoveItem(@p,where); { And put it on the floor. } + MoveInto(tmp,where); { Then we put both items into the pile. } + MoveInto(what,where); + Dispose(tmp); { W don't need third hand anymore. } + END; +END; + +PROCEDURE PutToPack(what: ItemSlot); { Tries to put an item into pack. } +BEGIN + IF (pc.inv[INV_PACK]=NIL) OR { Have we any pack to put into? } + NOT (ITEM_EMPTY IN pc.inv[INV_PACK]^.def^.flg) THEN Exit; + { We inform the player about what we are doing. } + Msg(Replace(Replace(msgs[15],'@1',ItemName(@(pc.inv[INV_PACK]))),'@v',ItemName(what))); + MoveInto(what,@(pc.inv[INV_PACK])); { And we do it. } +END; + +{ ------------------------------------------- Menus and handling -------- } + +PROCEDURE CheckCmd(VAR a:INTEGER;c:CHAR;b:BYTE);{ Checks if key C belong to command B } +BEGIN { and sets A to this command if so. } + IF c=cmd[b] THEN a:=b; +END; + +FUNCTION ListItems(where: ItemSlot):ItemSlot; { Lists all items in the container and picks one. } +VAR p,page: ItemSlot; + c,k: CHAR; +BEGIN + ListItems:=NIL; + ClrMsg; + p:=@(where^^.con); + REPEAT { Tell what item we are looking into. } + Msg(Replace(msgs[29],'@v',ItemName(where))); + + page:=p; { Mark the top of actual page. } + c:='a'; { Show a-p items. } + WHILE (p^<>NIL) AND (c<='p') DO BEGIN + Msg(Replace(Replace(msgs[30],'@1',c),'@v',ItemName(p))); + Inc(c); + p:=@(p^^.next); + END; + { Tell if there is more. } + IF (p^<>NIL) THEN Msg(msgs[19]); + + k:=GetKey; { Get players choice. } + ClrMsg; { And find this item. } + IF (k>='a') AND (k<c) THEN BEGIN + p:=page; + c:='a'; + WHILE (c<>k) DO BEGIN + Inc(c); + p:=@(p^^.next); + END; + ListItems:=p; + END; + IF k<>cmd[CMDMORE] THEN Exit; { If the player picked something -- we finish. } + IF p^=NIL THEN p:=@(where^^.con); + UNTIL FALSE; { And if not, we display another page. } +END; + +PROCEDURE SelectItem(what: ItemSlot); { Shows item description,asks for action and performs it. } +VAR c: CHAR; + l: INTEGER; + tmp: pItem; + s: STRING; + + AllowLoot, AllowPutInto, AllowHold, AllowDrop, AllowPack: BOOLEAN; + WhereEquip: BYTE; + +BEGIN + REPEAT + IF (what=NIL) OR (what^=NIL) OR { We won't select an empty item nor pile. } + (what^^.def^.id=PILEITEM) THEN BEGIN + Msg(msgs[10]); + Exit; + END; + + ClrMsg; + Msg(Replace(msgs[17],'@v',ItemName(what))); { We show item's name and description. } + {IF (ITEM_KNOWN IN what^^.flg) THEN} + Msg(GetItemDesc(what)); + + l:=GetItemWeight(what); { We display item's weight. } + IF l=1 THEN s:=Replace(msgs[33],'@s','') + ELSE s:=Plural(msgs[33]); + Msg(Replace(s,'@v',Num(l))); + + AllowHold:=FALSE; { Now we determine what actions can be performed. } + AllowPutInto:=FALSE; + AllowLoot:=FALSE; + AllowDrop:=FALSE; + AllowPack:=FALSE; + WhereEquip:=0; + + IF (pc.inv[INV_PACK]<>NIL)AND { If we have pack and the item we have selected isn't that pack, } + (ITEM_EMPTY IN pc.inv[INV_PACK]^.def^.flg)AND{we can put our item into pack. } + NOT(IsInThere(what,@(pc.inv[INV_PACK])))AND + (pc.inv[INV_PACK]<>what^) THEN AllowPack:=TRUE; + + IF pc.inv[INV_HELD]=NIL THEN AllowHold:=TRUE; { If the player character is empty handed, we can hold something. } + + IF (pc.inv[INV_HELD]<>NIL)AND { If the player holds something, and selected item is a container, + { he can put held item in. } + NOT(IsInThere(what,@(pc.inv[INV_HELD])))AND { But we have to make sure he won't put it into itself! } + (ITEM_EMPTY IN what^^.def^.flg) THEN AllowPutInto:=TRUE; + + IF (what^^.con<>NIL) THEN AllowLoot:=TRUE; { If it isn't empty, we can loot it. } + + { Dropping only when the item isn't on floor already. } + IF NOT(IsInThere(what,@(GetMap(playchr^.x,playchr^.y)^.slt))) THEN AllowDrop:=TRUE; + + WhereEquip:=what^^.def^.eqp; { And we can equip is if it can be equipped. :) } + + IF AllowHold THEN Msg(msgs[41]); { We display action names. } + IF AllowPutInto THEN Msg(msgs[42]); + IF WhereEquip>0 THEN Msg(msgs[44]); + IF AllowPack THEN Msg(msgs[45]); + IF AllowLoot THEN Msg(msgs[40]); + IF AllowDrop THEN Msg(msgs[43]); + + l:=CMDNOTHING; { Ask for action. } + c:=GetKey; + ClrMsg; + IF AllowPack THEN CheckCmd(l,c,CMDPUTTOPACK); + IF AllowLoot THEN CheckCmd(l,c,CMDLOOT); + IF AllowHold THEN CheckCmd(l,c,CMDUPINAIR); + IF AllowPutInto THEN CheckCmd(l,c,CMDUPINAIR); + IF WhereEquip>0 THEN CheckCmd(l,c,CMDEQUIP); + IF AllowDrop THEN CheckCmd(l,c,CMDDROP); + + CASE l OF { Perform the action. } + CMDLOOT: BEGIN { We list items inside and wait allow to select an item. } + what:=ListItems(what); + END; + CMDPUTTOPACK: BEGIN + PutToPack(what); { Simple. } + what:=NIL; { We don't want to select this item again. } + END; + CMDUPINAIR: IF AllowHold THEN BEGIN + MoveItem(what,@(pc.inv[INV_HELD])); + what:=NIL; + END ELSE IF AllowPutInto THEN BEGIN + MoveInto(@(pc.inv[INV_HELD]),what); + Msg(Replace(Replace(msgs[15],'@1',ItemName(what)) ,'@v',ItemName(@(pc.inv[INV_HELD])))); + what:=NIL; + END; + CMDDROP:BEGIN + DropItem(what,@(GetMap(playchr^.x,playchr^.y)^.slt)); + ShowItem(@(GetMap(playchr^.x,playchr^.y)^.slt)); + what:=NIL; + END; + CMDEQUIP:BEGIN { If there is an item equipped and player character is empty handed, we hold equipped item. } + IF pc.inv[WhereEquip]<>NIL THEN + IF pc.inv[INV_HELD]=NIL THEN MoveItem(@(pc.inv[WhereEquip]),@(pc.inv[INV_HELD])); + + { If the slot is free, we equip selected item. } + IF pc.inv[WhereEquip]=NIL THEN MoveItem(what,@(pc.inv[WhereEquip])) + ELSE Msg(msgs[32]); + what:=NIL; + END; + CMDNOTHING:BEGIN { If no action, we cancel selection. } + Msg(msgs[10]); + what:=NIL; + END; + END; + UNTIL what=NIL; { If the player haven't selected another item, we finish. } +END; + +PROCEDURE CheckPile(where: ItemSlot); { Destroys a pile if itsn't needed anymore. } +VAR tmp: ItemSlot; +BEGIN + IF where^=NIL THEN Exit; { If there is nothing there, we finish. } + IF where^^.def^.id<>PILEITEM THEN Exit; { If there is no pile, we finish too. } + + IF where^^.con=NIL THEN BEGIN { If the pile is empty, we simply destroy it. } + DestroyItem(where); + Exit; + END; + IF (where^^.con^.next=NIL) THEN BEGIN { If there is only one item in the pile.. } + New(tmp); { We need 'third hand'. } + tmp^:=NIL; + MoveItem(@(where^^.con),tmp); { We take the item out of pile. } + DestroyItem(where); { We destroy the pile. } + MoveItem(tmp,where); { Then we put the item on the floor. } + Dispose(tmp); { We don't need third hand. } + END; +END; + +PROCEDURE ExamInv; { Displays equipment. } +VAR c:CHAR; +BEGIN + ClrMsg; + Msg(Concat('@Ma@m)HELD: @M',ItemName(@(pc.inv[INV_HELD])))); + Msg(Concat('@Mb@m)PACK: @M',ItemName(@(pc.inv[INV_PACK])))); + Msg(Concat('@Mc@m)WEAR: @M',ItemName(@(pc.inv[INV_WEAR])))); + c:=GetKey; + ClrMsg; + CASE c OF + 'a': SelectItem(@pc.inv[INV_HELD]); + 'b': SelectItem(@pc.inv[INV_PACK]); + 'c': SelectItem(@pc.inv[INV_WEAR]); + END; +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/level.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,368 @@ +{ Level generating routines. } + +{$Q+R+} + +UNIT Level; + +INTERFACE +USES Global; + + PROCEDURE GenerateLevel; + +IMPLEMENTATION + +USES Console, Items, Creature; + +CONST GEN_EMPTY=0; { level generator values } + GEN_DOOR=1; + GEN_OCCUPY=2; + +TYPE TmpMap=ARRAY[0..MAPXSIZE,0..MAPYSIZE] OF BYTE; + +VAR gen: TmpMap; + m: TmpMap; + +PROCEDURE ClearMap; +VAR x,y: INTEGER; + m: pMap; + nothing: TileDef; +BEGIN + nothing:=FindTile(0); + GetMap(playchr^.x,playchr^.y)^.crt:=NIL; + FOR y:=0 TO MAPYSIZE DO + FOR x:=0 TO MAPXSIZE DO BEGIN + m:=GetMap(x,y); + IF m^.slt<>NIL THEN BEGIN + Dispose(m^.slt); + m^.slt:=NIL; + END; + IF m^.crt<>NIL THEN BEGIN + Dispose(m^.crt); + m^.crt:=NIL; + END; + m^.flg:=[]; + m^.ter:=nothing; + END; + allmonsters:=NIL; +END; + +PROCEDURE GenMap; +VAR x,y: INTEGER; +BEGIN + FOR y:=0 TO MAPYSIZE DO + FOR x:=0 TO MAPXSIZE DO BEGIN + GetMap(x,y)^.ter:=FindTile(m[x,y]); + END; +END; + +PROCEDURE GenBack(lev: pLevel); +VAR r,i,s,x,y,a,b: INTEGER; + frak: TmpMap; + +BEGIN + FOR y:=0 TO MAPYSIZE DO + FOR x:=0 TO MAPXSIZE DO m[x,y]:=lev^.back[0]; +END; + +PROCEDURE Erode(lev:pLevel); +VAR x,y,r: INTEGER; +BEGIN + FOR y:=0 TO MAPYSIZE DO + FOR x:=0 TO MAPXSIZE DO + IF lev^.erosion>Random(100) THEN BEGIN + r:=FindTile(m[x,y])^.dst; + IF r>0 THEN m[x,y]:=r; + END; +END; + + +PROCEDURE GenLevel(lev:pLevel); + +VAR r,i,j,p,x1,y1,x,y: INTEGER; + door: BYTE; + rom: pRoom; + place: BYTE; + pmap: tmpmap; + tmpplaces: Places; + +FUNCTION TryRoom(x,y: INTEGER; rom: pRoom): BOOLEAN; +VAR x1,y1: INTEGER; + + +BEGIN + IF rom=NIL THEN Exit; + TryRoom:=FALSE; + FOR y1:=0 TO 15 DO FOR x1:=0 TO 15 DO + IF (rom^.map[x1,y1]<>GEN_EMPTY) THEN BEGIN + IF (NOT InMap(x+x1,y+y1)) THEN Exit; + IF (gen[x+x1,y+y1]=GEN_OCCUPY) THEN Exit; + END; + TryRoom:=TRUE; +END; + +PROCEDURE RotateRoom(rom:pRoom); +VAR x,y: INTEGER; + tmp: ARRAY[0..15,0..15] OF BYTE; +BEGIN + FOR y:=0 TO 15 DO + FOR x:=0 TO 15 DO + tmp[x,y]:=rom^.map[y,15-x]; + FOR y:=0 TO 15 DO + FOR x:=0 TO 15 DO + rom^.map[x,y]:=tmp[x,y]; +END; + +PROCEDURE PutDoor(x,y:INTEGER); +VAR p: INTEGER; + +BEGIN + gen[x,y]:=GEN_OCCUPY; + IF door=0 THEN Exit; + m[x,y]:=door; +END; + + +PROCEDURE PutRoom(x,y: INTEGER; rom: pRoom); +VAR x1,y1: INTEGER; +BEGIN + IF rom=NIL THEN Exit; + IF tmpplaces[place].qnt>0 THEN Dec(tmpplaces[place].qnt); + door:=tmpplaces[place].dor; + FOR y1:=0 TO 15 DO FOR x1:=0 TO 15 DO + IF InMap(x+x1,y+y1) AND (gen[x+x1,y+y1]<>GEN_OCCUPY) THEN BEGIN + CASE rom^.map[x1,y1] OF + GEN_EMPTY: {nothing}; + GEN_OCCUPY: gen[x+x1,y+y1]:=GEN_EMPTY; + GEN_DOOR: IF gen[x+x1,y+y1]=GEN_EMPTY THEN BEGIN + gen[x+x1,y+y1]:=GEN_DOOR; + pmap[x+x1,y+y1]:=place; + END ELSE BEGIN + IF (ROOM_EASYDOOR IN rom^.flg) AND (gen[x+x1,y+y1]=GEN_DOOR) THEN PutDoor(x+x1,y+y1) ELSE + gen[x+x1,y+y1]:=GEN_OCCUPY; + END; + ELSE BEGIN + gen[x+x1,y+y1]:=GEN_OCCUPY; + m[x+x1,y+y1]:=rom^.map[x1,y1]; + END; + END; + END; +END; + + +PROCEDURE NextRoom(x,y: INTEGER); +VAR a: INTEGER; +BEGIN + a:=place; + place:=pmap[x1,y1]; + REPEAT + Inc(a); + IF a>MAXROOMS THEN a:=1; + UNTIL (tmpplaces[place].con[a]<>0) AND (tmpplaces[tmpplaces[place].con[a]].qnt<>0); + + place:=tmpplaces[place].con[a]; + rom:=FindRoom(tmpplaces[place].rom); + + a:=Random(100); + IF (a<70) THEN RotateRoom(rom); +END; + +PROCEDURE RandomRoom(x,y: INTEGER); +VAR a: INTEGER; +BEGIN + place:=pmap[x1,y1]; + a:=Random(MAXROOMS)+1; + WHILE (tmpplaces[place].con[a]=0) OR (tmpplaces[tmpplaces[place].con[a]].qnt=0) DO BEGIN + Inc(a); + IF a>MAXROOMS THEN a:=1; + END; + + place:=tmpplaces[place].con[a]; + rom:=FindRoom(tmpplaces[place].rom); + + a:=Random(100); + IF (a<70) THEN RotateRoom(rom); +END; + +FUNCTION PickRoom: BOOLEAN; +VAR i,j,k,l: INTEGER; +BEGIN + place:=pmap[x1,y1]; + door:=tmpplaces[place].dor; + + PickRoom:=FALSE; + + IF tmpplaces[place].con[1]=0 THEN Exit; + +{ IF (gen[x1+1,y1]<>GEN_EMPTY) AND + (gen[x1-1,y1]<>GEN_EMPTY) AND + (gen[x1,y1+1]<>GEN_EMPTY) AND + (gen[x1,y1-1]<>GEN_EMPTY) THEN Exit;} + + PickRoom:=TRUE; + + RandomRoom(x1,y1); + + + FOR k:=1 TO 4 DO BEGIN + x:=Random(15); + y:=Random(15); + + FOR j:=1 TO 2 DO BEGIN + i:=0; + REPEAT + Inc(x); + IF x>15 THEN BEGIN + x:=0; + Inc(y); + IF y>15 THEN y:=0; + END; + Inc(i); + IF (i>200) THEN BEGIN + NextRoom(x1,y1); + x:=Random(15); + y:=Random(15); + END; + UNTIL (rom^.map[x,y]=GEN_DOOR); + IF TryRoom(x1-x,y1-y,rom) THEN Exit; + RotateRoom(rom); + END; + NextRoom(x1,y1); + END; + PickRoom:=FALSE; +END; + + +BEGIN + tmpplaces:=lev^.rooms; + + FOR y:=0 TO MAPYSIZE DO + FOR x:=0 TO MAPXSIZE DO BEGIN + gen[x,y]:=GEN_EMPTY; + pmap[x,y]:=0; + END; + + place:=1; + rom:=FindRoom(tmpplaces[place].rom); + door:=rom^.dor; + + + Msg('@cTrying first room...'); + REPEAT + + x:=Random(MAPXSIZE); + dec(x,8); + y:=Random(MAPYSIZE); + dec(y,8); + Msg(Concat('@cx=',Num(x),';y=',Num(y))); + UNTIL TryRoom(x,y,rom); + Msg('@cPutting first room...'); + + PutRoom(x,y,rom); + + + Msg('@cFirst room put...'); + +REPEAT + + x1:=Random(MAPXSIZE); + y1:=Random(MAPYSIZE); + + i:=0; + r:=Random(4); + CASE r OF + 0:WHILE gen[x1,y1]<>GEN_DOOR DO BEGIN + Inc(x1); + IF x1>MAPXSIZE-1 THEN BEGIN + x1:=1; + Inc(y1); + IF y1>MAPYSIZE-1 THEN y1:=1; + END; + Inc(i); + IF i>MAPXSIZE*MAPYSIZE THEN BEGIN + + Exit; + END; + END; + 1:WHILE gen[x1,y1]<>GEN_DOOR DO BEGIN + Dec(x1); + IF x1<1 THEN BEGIN + x1:=MAPXSIZE-1; + Dec(y1); + IF y1<1 THEN y1:=MAPYSIZE-1; + END; + Inc(i); + IF i>MAPXSIZE*MAPYSIZE THEN BEGIN + + Exit; + END; + END; + 2:WHILE gen[x1,y1]<>GEN_DOOR DO BEGIN + Inc(y1); + IF y1>MAPYSIZE-1 THEN BEGIN + y1:=1; + Inc(x1); + IF x1>MAPXSIZE-1 THEN x1:=1; + END; + Inc(i); + IF i>MAPXSIZE*MAPYSIZE THEN BEGIN + + Exit; + END; + END; + 3: WHILE gen[x1,y1]<>GEN_DOOR DO BEGIN + Dec(y1); + IF y1<1 THEN BEGIN + y1:=MAPYSIZE-1; + Dec(x1); + IF x1<1 THEN x1:=MAPXSIZE-1; + END; + Inc(i); + IF i>MAPXSIZE*MAPYSIZE THEN BEGIN + + Exit; + END; + END; + END; + + Msg('@cPicking room...'); + + IF PickRoom THEN BEGIN + Msg('@cPutting room...'); + PutDoor(x1,y1); + PutRoom(x1-x,y1-y,rom); + END ELSE BEGIN + gen[x1,y1]:=GEN_EMPTY; + END; + +UNTIL FALSE; +END; + + +PROCEDURE GenerateLevel; +VAR x,y,i,a,b: INTEGER; + l: pLevel; + p: pCreat; +BEGIN + ClearMap; + l:=FindLevel(pc.lev); + Msg(Replace(msgs[12],'@v',l^.name)); + GenBack(l); + Msg('@cGenerated back...'); + GenLevel(l); + Msg('@cGenerated rooms...'); + Erode(l); + Msg('@cEroded...'); + GenMap; + + FOR y:=0 TO MAPYSIZE DO + FOR x:=0 TO MAPXSIZE DO BEGIN + IF (TILE_ENTER IN GetMap(x,y)^.ter^.flg) THEN BEGIN + p:=playchr; + MoveMonster(x,y,p); + END; + END; + Inc(pc.lev); +END; + + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/light.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,165 @@ +{ Field of vision counting routines. } + +UNIT Light; + +INTERFACE + +PROCEDURE MakeLut; +PROCEDURE ApplyFov(cx,cy: INTEGER); + +IMPLEMENTATION + +USES Global; + +CONST LOS_LINES=127; +VAR lut: ARRAY[0..MAPXSIZE,0..MAPYSIZE,0..1] OF BYTE; + + +FUNCTION Min(a,b: INTEGER): INTEGER; +BEGIN + IF a<b THEN Min:=a ELSE Min:=b; +END; + +FUNCTION Max(a,b: INTEGER): INTEGER; +BEGIN + IF a>b THEN Max:=a ELSE Max:=b; +END; + + +PROCEDURE MakeLut; +VAR a,d,x,y,lx,ly,dx,dy,ile: INTEGER; + s,c,an: REAL; +BEGIN + + FOR x:=0 TO MAPXSIZE DO + FOR y:=0 TO MAPYSIZE DO BEGIN + lut[x,y][0]:=255; + lut[x,y][1]:=0; + END; + + FOR a:=0 TO LOS_LINES DO BEGIN + an:=(a*PI)/(los_lines*2); + s:=Sin(an)/4; + c:=Cos(an)/4; + lx:=0; + ly:=0; + d:=0; + REPEAT + x:=Trunc(s*d); + y:=Trunc(c*d); + + dx:=(x-lx); + dy:=(y-ly); + IF (x<=MAPXSIZE) AND (y<=MAPYSIZE) THEN BEGIN + lut[x,y][0]:=Min(lut[x,y][0],a); + lut[x,y][1]:=Max(lut[x,y][0],a); + END; + Inc(d); + UNTIL (x>MAPXSIZE) OR (y>MAPYSIZE); + END; +END; + + +PROCEDURE ApplyFov(cx,cy: INTEGER); +VAR rays: ARRAY[0..LOS_LINES] OF BOOLEAN; + x,y: INTEGER; + i,f,t: BYTE; + bl: BOOLEAN; + pow: BOOLEAN; + m: pMap; + +BEGIN + FOR i:=0 TO LOS_LINES DO rays[i]:=TRUE; + + FOR y:=cy TO MAPYSIZE DO + FOR x:=cx TO MAPXSIZE DO BEGIN + m:=GetMap(x,y); + pow:=FALSE; + + bl:=(m^.ter^.vis<50); + + f:=lut[x-cx,y-cy][0]; + t:=lut[x-cx,y-cy][1]; + + FOR i:=f TO t DO IF rays[i] THEN BEGIN + pow:=TRUE; + IF NOT bl THEN rays[i]:=FALSE; + END; + + IF pow THEN BEGIN + m^.flg:=m^.flg+[MAP_VISIBLE]; + m^.flg:=m^.flg+[MAP_EXPLORED]; + END ELSE m^.flg:=m^.flg-[MAP_VISIBLE]; + END; + + FOR i:=0 TO LOS_LINES DO rays[i]:=TRUE; + + FOR y:=cy DOWNTO 0 DO + FOR x:=cx TO MAPXSIZE DO BEGIN + m:=GetMap(x,y); + pow:=FALSE; + + bl:=(m^.ter^.vis<50); + + f:=lut[x-cx,cy-y][0]; + t:=lut[x-cx,cy-y][1]; + + FOR i:=f TO t DO IF rays[i] THEN BEGIN + pow:=TRUE; + IF NOT bl THEN rays[i]:=FALSE; + END; + + IF pow THEN BEGIN + m^.flg:=m^.flg+[MAP_VISIBLE]; + m^.flg:=m^.flg+[MAP_EXPLORED]; + END ELSE m^.flg:=m^.flg-[MAP_VISIBLE]; + END; + + FOR i:=0 TO LOS_LINES DO rays[i]:=TRUE; + + FOR y:=cy TO MAPYSIZE DO + FOR x:=cx DOWNTO 0 DO BEGIN + m:=GetMap(x,y); + + pow:=FALSE; + bl:=(m^.ter^.vis<50); + + f:=lut[cx-x,y-cy][0]; + t:=lut[cx-x,y-cy][1]; + + FOR i:=f TO t DO IF rays[i] THEN BEGIN + pow:=TRUE; + IF NOT bl THEN rays[i]:=FALSE; + END; + + IF pow THEN BEGIN + m^.flg:=m^.flg+[MAP_VISIBLE]; + m^.flg:=m^.flg+[MAP_EXPLORED]; + END ELSE m^.flg:=m^.flg-[MAP_VISIBLE]; + END; + + FOR i:=0 TO LOS_LINES DO rays[i]:=TRUE; + + FOR y:=cy DOWNTO 0 DO + FOR x:=cx DOWNTO 0 DO BEGIN + m:=GetMap(x,y); + pow:=FALSE; + + bl:=(m^.ter^.vis<50); + + f:=lut[cx-x,cy-y][0]; + t:=lut[cx-x,cy-y][1]; + + FOR i:=f TO t DO IF rays[i] THEN BEGIN + pow:=TRUE; + IF NOT bl THEN rays[i]:=FALSE; + END; + + IF pow THEN BEGIN + m^.flg:=m^.flg+[MAP_VISIBLE]; + m^.flg:=m^.flg+[MAP_EXPLORED]; + END ELSE m^.flg:=m^.flg-[MAP_VISIBLE]; + END; +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/maps.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,118 @@ +{ Map scrolling and display routines. } + +{$Q+R+} + +UNIT Maps; + +INTERFACE +USES Global; + +VAR xMapShift, yMapShift: INTEGER; +PROCEDURE Refresh; +PROCEDURE CenterMap(x,y:INTEGER); +PROCEDURE ReLight(px,py: INTEGER); +PROCEDURE ShowPlayer(x,y: INTEGER); +PROCEDURE Demolish(m: pMap); +FUNCTION FreeToMove(m: pMap): BOOLEAN; + +IMPLEMENTATION + +USES Console, Items, Light; + +FUNCTION FreeToMove(m: pMap): BOOLEAN; +BEGIN + FreeToMove:=FALSE; + + IF m=NIL THEN Exit; + IF m^.crt<>NIL THEN Exit; + IF m^.ter^.mov>=100 THEN Exit; + + FreeToMove:=TRUE; +END; + +PROCEDURE ShowMap(x,y:INTEGER); +VAR a:BYTE; + c:CHAR; + m:pMap; +BEGIN + IF NOT InMap(x,y) THEN BEGIN + PutChr(x-xMapShift,y-yMapShift,' ',$07); + Exit; + END; + m:=GetMap(x,y); + + IF (x-xMapShift<0) OR (x-xMapShift>49) OR (y-yMapShift<0) OR (y-yMapShift>24) THEN Exit; + + a:=m^.ter^.atr; + c:=m^.ter^.chr; + + IF (TILE_SMARTDOOR IN m^.ter^.flg) THEN + IF (x=0) OR (x=MAPXSIZE) OR + (GetMap(x-1,y)^.ter^.mov>=100) OR + (GetMap(x+1,y)^.ter^.mov>=100) THEN c:='-'; + + IF (m^.ter^.vis<30) AND (y>0)AND + (GetMap(x,y-1)^.ter^.vis>=30) THEN BEGIN + CASE a OF + 15: a:=7; + 13: a:=14; + 8: a:=8; + 7: a:=8; + ELSE a:=a AND $F7; + END; + END; + + + IF NOT(MAP_EXPLORED IN m^.flg) THEN c:=' '; + + IF NOT(MAP_VISIBLE IN m^.flg) THEN a:=shadecolor ELSE BEGIN + IF (m^.slt<>NIL) + {AND (TILE_ITEM IN m^.ter^.flg)} + THEN GetItemLooks(a,c,@(m^.slt)); + IF (m^.crt<>NIL) THEN BEGIN + a:=m^.crt^.def^.atr; + c:=m^.crt^.def^.chr; + END; + END; + + + PutChr(x-xMapShift,y-yMapShift,c,a); +END; + +PROCEDURE Demolish(m: pMap); +BEGIN + IF m^.ter^.dst=0 THEN Exit; + IF (m^.ter^.drp>0) AND (m^.slt=NIL) THEN BEGIN + m^.slt:=GenerateItem(m^.ter^.drp); + END; + m^.ter:=FindTile(m^.ter^.dst); +END; + +PROCEDURE Refresh; +VAR x,y: INTEGER; +BEGIN + FOR y:=0 TO 24 DO + FOR x:=0 TO 49 DO ShowMap(x+xMapShift,y+yMapShift); +END; + +PROCEDURE CenterMap(x,y:INTEGER); +BEGIN + xMapShift:=x-25; + yMapShift:=y-12; + Refresh; +END; + +PROCEDURE ShowPlayer(x,y: INTEGER); +BEGIN + IF NOT InMap(x,y) THEN Exit; + IF (x-xMapShift<MARGIN) OR (x-xMapShift>49-MARGIN) OR (y-yMapShift<MARGIN) OR (y-yMapShift>24-MARGIN) THEN CenterMap(x,y); + Cursor(x-xMapShift,y-yMapShift); +END; + +PROCEDURE ReLight(px,py: INTEGER); +BEGIN + ApplyFov(px,py); + Refresh; +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/parser.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,158 @@ +{ File i/o and parsing routines. } + +UNIT Parser; + +INTERFACE + +USES Gzio; + +CONST REMCHAR='#'; + REMEND=#13; + STRCHAR='"'; + VRBCHAR='\'; + +{ TYPE CfgFile=FILE OF CHAR; } +TYPE CfgFile=gzFile; + +CONST PARSE_NOERROR=0; + PARSE_ERR_EOF=1; + PARSE_ERR_NUM=2; + PARSE_ERR_STR=3; + PARSE_ERR_NAM=4; + PARSE_ERR_OPN=5; + +VAR errNum:BYTE; + actLine: WORD; +FUNCTION ReadName(VAR f:CfgFile):STRING; +FUNCTION ReadString(VAR f:CfgFile):STRING; +FUNCTION ReadNumber(VAR f:CfgFile):INTEGER; +PROCEDURE OpenCfg(VAR f:CfgFile; name: STRING); +PROCEDURE CloseCfg(VAR f:CfgFile); + +IMPLEMENTATION + +CONST CHR_EOF=#26; + +PROCEDURE OpenCfg(VAR f:CfgFile; name: STRING); +BEGIN + actLine:=1; + errNum:=PARSE_NOERROR; + + f:=gzOpen(name,'r'); + IF f=NIL THEN BEGIN + errNum:=PARSE_ERR_OPN; + WriteLn('Can''t open ',name); + END; +END; + +PROCEDURE CloseCfg(VAR f:CfgFile); +BEGIN + IF gzClose(f)>0 THEN errNum:=PARSE_ERR_OPN; +END; + +FUNCTION ReadChr(VAR f:CfgFile): CHAR; +VAR c: CHAR; + b: INTEGER; +BEGIN + b:=gzGetC(f); + + IF (b<0) OR (b>255) OR (c=CHR_EOF) THEN BEGIN + errNum:=PARSE_ERR_EOF; + c:=CHR_EOF; + END ELSE c:=Chr(b); + + IF c=#13 THEN Inc(actLine); + ReadChr:=c; +END; + +FUNCTION IsEmpty(c:CHAR):BOOLEAN; +BEGIN + IsEmpty:=(c=' ') OR (c=#9) OR (c=#13) OR (c=#10) OR (c=CHR_EOF); +END; + +FUNCTION ReadName(VAR f:CfgFile):STRING; +VAR s: STRING; + c: CHAR; +BEGIN + ReadName:=''; + REPEAT + c:=ReadChr(f); + IF c=REMCHAR THEN BEGIN + REPEAT + c:=ReadChr(f); + UNTIL (c=REMEND) OR (c=CHR_EOF); + IF (c<>CHR_EOF) THEN c:=' '; + END; + UNTIL (NOT IsEmpty(c)) OR (c=CHR_EOF); + s:=''; + WHILE NOT IsEmpty(c) DO BEGIN + s:=Concat(s,UpCase(c)); + c:=ReadChr(f); + END; + IF s='' THEN errNum:=PARSE_ERR_NAM; + ReadName:=s; +END; + +FUNCTION ReadString(VAR f:CfgFile):STRING; +VAR s: STRING; + c: CHAR; +BEGIN + ReadString:=''; + REPEAT + c:=ReadChr(f); + IF c=REMCHAR THEN BEGIN + REPEAT + c:=ReadChr(f); + UNTIL (c=REMEND) OR (c=CHR_EOF); + IF (c<>CHR_EOF) THEN c:=' '; + END; + UNTIL (NOT IsEmpty(c)) OR (c=CHR_EOF); + s:=''; + IF c<>STRCHAR THEN BEGIN + errNum:=PARSE_ERR_STR; + END ELSE BEGIN + REPEAT + c:=ReadChr(f); + IF c=STRCHAR THEN Break; + IF c=#13 THEN BEGIN + ErrNum:=PARSE_ERR_STR; + Exit; + END; + IF c=CHR_EOF THEN Exit; + IF c=VRBCHAR THEN BEGIN + c:=ReadChr(f); + END; + s:=Concat(s,c); + UNTIL FALSE; + END; + ReadString:=s; +END; + +FUNCTION ReadNumber(VAR f:CfgFile):INTEGER; +VAR s: STRING; + c: CHAR; + i,j: INTEGER; +BEGIN + ReadNumber:=0; + REPEAT + c:=ReadChr(f); + IF c=REMCHAR THEN BEGIN + REPEAT + c:=ReadChr(f); + UNTIL (c=REMEND) OR (c=CHR_EOF); + IF (c<>CHR_EOF) THEN c:=' '; + END; + UNTIL (NOT IsEmpty(c)) OR (c=CHR_EOF); + s:=''; + WHILE NOT IsEmpty(c) DO BEGIN + s:=Concat(s,UpCase(c)); + c:=ReadChr(f); + END; + Val(s,i,j); + IF j=0 THEN ReadNumber:=i + ELSE BEGIN + errNum:=PARSE_ERR_NUM; + END; +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/player.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,374 @@ +{ Player character handling routines. } + +UNIT Player; + +INTERFACE + +PROCEDURE Play; +PROCEDURE GeneratePlayer; +PROCEDURE ShowStats; + +IMPLEMENTATION + +USES Global, Console, Level, Items, Maps, Creature, Save, Porting; + +PROCEDURE CheckCmd(VAR a:INTEGER;c:CHAR;b:BYTE); +BEGIN + IF c=cmd[b] THEN a:=b; +END; + + +PROCEDURE ShowStats; +VAR s: STRING; + n: STRING[8]; +BEGIN + s:=stat_string; + n:=playchr^.def^.nam+' '; + s:=Replace(s,'@v',n); + s:=Replace(s,'@1',Number(playchr^.hp)); + s:=Replace(s,'@2',Number(playchr^.def^.hp)); + s:=Replace(s,'@3',Number(pc.stats[2])); + s:=Replace(s,'@4',Number(pc.stats[3])); + s:=Replace(s,'@5',Number(pc.stats[4])); + s:=Replace(s,'@6',Number(pc.stats[5])); + s:=Replace(s,'@7',Number(pc.stats[6])); + s:=Replace(s,'@8',Number(pc.stats[7])); + s:=Replace(s,'@9',Number(pc.stats[8])); + s:=Replace(s,'@0',Number(pc.stats[9])); + Stat(s); +END; + + +PROCEDURE Aim(VAR x,y: INTEGER; near:BOOLEAN); +VAR c: CHAR; + b,nx,ny: INTEGER; +BEGIN + IF NOT InMap(x,y) THEN Exit; + REPEAT + GotoXY(x-xMapShift,y-yMapShift); + c:=GetKey; + b:=CMDNOTHING; + CheckCmd(b,c,CMDSOUTHWEST); + CheckCmd(b,c,CMDSOUTHWEST); + CheckCmd(b,c,CMDSOUTH); + CheckCmd(b,c,CMDSOUTHEAST); + CheckCmd(b,c,CMDWEST); + CheckCmd(b,c,CMDEAST); + CheckCmd(b,c,CMDNORTHWEST); + CheckCmd(b,c,CMDNORTH); + CheckCmd(b,c,CMDNORTHEAST); + IF b=CMDNOTHING THEN Exit; + IF InMap(x+DIRX[b],y+DIRY[b]) AND + (x-xMapShift+DIRX[b]>0 ) AND + (x-xMapShift+DIRX[b]<49) AND + (y-yMapShift+DIRY[b]>0 ) AND + (y-yMapShift+DIRY[b]<24) THEN BEGIN; + Inc(x,DIRX[b]); + Inc(y,DIRY[b]); + END; + IF (x-xMapShift<MARGIN) OR (x-xMapShift>49-MARGIN) OR (y-yMapShift<MARGIN) OR (y-yMapShift>24-MARGIN) THEN CenterMap(x,y); + UNTIL near; +END; + +PROCEDURE Wait(t:INTEGER); +BEGIN +{ IF (TILE_BURN IN GetMap(playchr^.x,playchr^.y)^.ter^.flg) THEN BEGIN + Msg(msgs[23]); + END; + + IF (TILE_SWIM IN GetMap(playchr^.x,playchr^.y)^.ter^.flg) THEN BEGIN + Msg(msgs[24]); + END;} + + Inc(playchr^.mov,t); +END; + +PROCEDURE DoWait; +BEGIN + Msg(msgs[11]); + CenterMap(playchr^.x,playchr^.y); + Wait(50); +END; + +PROCEDURE DoBash(x,y: INTEGER); +VAR m: pMap; +BEGIN + IF pc.crouch THEN BEGIN + Msg(msgs[28]); + Exit; + END; + + m:=GetMap(x,y); + + IF m^.crt<>NIL THEN BEGIN + Msg(Replace(msgs[2],'@v',m^.crt^.def^.nam)); + END ELSE BEGIN + Msg(Replace(msgs[3],'@v',m^.ter^.nam)); + Demolish(m); + Wait(100); + END; +END; + + +PROCEDURE DoOperate(x,y: INTEGER); +VAR m: pMap; +BEGIN + m:=GetMap(x,y); + + IF NOT (TILE_OPERATE IN m^.ter^.flg) THEN BEGIN + Msg(msgs[7]); + Exit; + END; + IF m^.ter^.chn>0 THEN BEGIN + m^.ter:=FindTile(m^.ter^.chn); + + Wait(60); + END; +END; + +PROCEDURE DoWalk(x,y: INTEGER); +BEGIN + IF NOT InMap(x,y) THEN Exit; + IF (GetMap(x,y)^.ter^.mov>=100) THEN Exit; + IF pc.crouch THEN BEGIN + Msg(msgs[25]); + Wait(50); + END; + MoveMonster(x,y,playchr); + ShowItem(@(GetMap(x,y)^.slt)); +END; + +PROCEDURE DoLook(x,y: INTEGER); +VAR m: pMap; +BEGIN + m:=GetMap(x,y); + IF (MAP_EXPLORED IN m^.flg) THEN Msg(Replace(msgs[5],'@v',m^.ter^.nam)) + ELSE Msg(msgs[14]); + IF (MAP_VISIBLE IN m^.flg) AND (m^.slt<>NIL) THEN ShowItem(@(m^.slt)); + IF (MAP_VISIBLE IN m^.flg) AND (m^.crt<>NIL) THEN ShowMonster(m); +END; + + +PROCEDURE DoEnter; +BEGIN + IF NOT (TILE_ENTER IN GetMap(playchr^.x,playchr^.y)^.ter^.flg) THEN BEGIN + Msg(msgs[8]); + Exit; + END; + GenerateLevel; + + {IF pc.intown THEN GenerateLevel ELSE TownMap; + pc.intown:=NOT pc.intown;} + + + CenterMap(playchr^.x,playchr^.y); +END; + +PROCEDURE DoInfo; +VAR s: STRING; + l: LONGINT; +BEGIN + l:=MemAvail; + Str(l,s); + Msg(Concat('Memory: @M',s)); + Msg(Concat('Time: @M',Num(gametime))); +END; + + +PROCEDURE DoHelp; +VAR l: INTEGER; +BEGIN + FOR l:=0 TO MAXLONGSTRING DO + IF help_string[l]<>'' THEN Msg(help_string[l]); +END; + +PROCEDURE DoDie; +VAR l: INTEGER; +BEGIN + FOR l:=0 TO MAXLONGSTRING DO + IF death_string[l]<>'' THEN Msg(death_string[l]); +END; + +PROCEDURE DoSkills; +BEGIN + Msg('Skills...'); +END; + +PROCEDURE DoCrouch; +BEGIN + IF pc.crouch THEN BEGIN + pc.crouch:=FALSE; + Msg(msgs[27]); + Wait(50); + END ELSE BEGIN + pc.crouch:=TRUE; + Msg(msgs[26]); + Wait(50); + END; +END; + +PROCEDURE DoPickup; +VAR m:pMap; +BEGIN + m:=GetMap(playchr^.x,playchr^.y); + IF m^.slt=NIL THEN BEGIN + Msg(msgs[9]); + Exit; + END; + + IF m^.slt^.def^.id=PILEITEM THEN BEGIN + SelectItem(ListItems(@(m^.slt))); + CheckPile(@(m^.slt)); + END ELSE BEGIN + SelectItem(@(m^.slt)); + END; +END; + +PROCEDURE DoPack; +VAR m:pMap; +BEGIN + m:=GetMap(playchr^.x,playchr^.y); + + IF m^.slt=NIL THEN BEGIN + Msg(msgs[9]); + Exit; + END; + + IF m^.slt^.def^.id=PILEITEM THEN BEGIN + PutToPack(ListItems(@m^.slt)); + CheckPile(@(m^.slt)); + END ELSE BEGIN + PutToPack(@(m^.slt)); + END; +END; + +PROCEDURE DoShoot(x,y: INTEGER); +BEGIN + BulletFly(playchr^.x,playchr^.y,x,y); +END; + +PROCEDURE Play; +VAR c: CHAR; + x,y,d: INTEGER; + s: STRING; + +BEGIN + ReLight(playchr^.x,playchr^.y); + + ShowPlayer(playchr^.x,playchr^.y); + + c:=GetKey; + y:=CMDNOTHING; + CheckCmd(y,c,CMDSOUTHWEST); + CheckCmd(y,c,CMDSOUTHWEST); + CheckCmd(y,c,CMDSOUTH); + CheckCmd(y,c,CMDSOUTHEAST); + CheckCmd(y,c,CMDWEST); + CheckCmd(y,c,CMDEAST); + CheckCmd(y,c,CMDNORTHWEST); + CheckCmd(y,c,CMDNORTH); + CheckCmd(y,c,CMDNORTHEAST); + + CheckCmd(y,c,CMDHERE); + CheckCmd(y,c,CMDLOOK); + CheckCmd(y,c,CMDOPERATE); + CheckCmd(y,c,CMDBASH); + CheckCmd(y,c,CMDENTER); + CheckCmd(y,c,CMDPICKUP); + CheckCmd(y,c,CMDEXAM); + CheckCmd(y,c,CMDINFO); + CheckCmd(y,c,CMDCROUCH); + CheckCmd(y,c,CMDPACK); + CheckCmd(y,c,CMDINVEN); + CheckCmd(y,c,CMDSKILLS); + CheckCmd(y,c,CMDAIM); + + CheckCmd(y,c,CMDQUIT); + CheckCmd(y,c,CMDHELP); + CheckCmd(y,c,CMDSAVE); + + CASE y OF + CMDSAVE: SaveGame; + CMDQUIT:BEGIN + DoDie; + GetKey; + ResetScr; + HALT; + END; + CMDNOTHING: Msg(msgs[0]); +CMDSOUTHWEST,CMDSOUTH,CMDSOUTHEAST,CMDWEST,CMDEAST,CMDNORTHWEST,CMDNORTH,CMDNORTHEAST: BEGIN + x:=playchr^.x+DIRX[y]; + y:=playchr^.y+DIRY[y]; + IF InMap(x,y) THEN BEGIN + IF GetMap(x,y)^.crt<>NIL THEN DoBash(x,y) + ELSE BEGIN + IF (GetMap(x,y)^.ter^.mov>=100) THEN BEGIN + IF (TILE_OPERATE IN GetMap(x,y)^.ter^.flg) THEN DoOperate(x,y) ELSE + IF (TILE_FRAGILE IN GetMap(x,y)^.ter^.flg) AND NOT pc.crouch THEN DoBash(x,y); + END ELSE DoWalk(x,y); + END; + END; + END; + CMDHERE:DoWait; + CMDHELP:DoHelp; + CMDLOOK:BEGIN + Msg(msgs[4]); + x:=playchr^.x; + y:=playchr^.y; + Aim(x,y,FALSE); + IF (x=playchr^.x) AND (y=playchr^.y) THEN Msg(msgs[10]) + ELSE DoLook(x,y); + END; + CMDOPERATE:BEGIN + Msg(msgs[6]); + x:=playchr^.x; + y:=playchr^.y; + Aim(x,y,TRUE); + IF (x=playchr^.x) AND (y=playchr^.y) THEN Msg(msgs[10]) + ELSE DoOperate(x,y); + END; + CMDBASH: BEGIN + Msg(msgs[21]); + x:=playchr^.x; + y:=playchr^.y; + Aim(x,y,TRUE); + IF (x=playchr^.x) AND (y=playchr^.y) THEN Msg(msgs[10]) + ELSE DoBash(x,y); + END; + CMDENTER: DoEnter; + CMDEXAM: ExamInv; + CMDPICKUP: DoPickup; + CMDINFO: DoInfo; + CMDCROUCH: DoCrouch; + CMDSKILLS: DoSkills; + CMDPACK: IF (pc.inv[1]<>NIL) AND (ITEM_EMPTY IN pc.inv[1]^.def^.flg) THEN DoPack + ELSE Msg(msgs[31]); + CMDINVEN: IF (pc.inv[1]<>NIL) AND (ITEM_EMPTY IN pc.inv[1]^.def^.flg) THEN BEGIN + IF pc.inv[1]^.con<>NIL THEN SelectItem(ListItems(@pc.inv[1])) + ELSE Msg(msgs[9]); + END ELSE Msg(msgs[31]); + + CMDAIM: BEGIN + Msg(msgs[1]); + x:=playchr^.x; + y:=playchr^.y; + Aim(x,y,FALSE); + IF (x=playchr^.x) AND (y=playchr^.y) THEN Msg(msgs[10]) + ELSE DoShoot(x,y); + END; + END; +END; + + +PROCEDURE GeneratePlayer; +VAR s:STRING; +BEGIN + playchr:=GenerateMonster(0); + Msg(msgs[35]); + REPEAT + s:=GetString(8); + UNTIL s<>''; + playchr^.def^.nam:=Capitalize(s); +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/porting.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,167 @@ +{ All system-dependant procedures should be here. } + +UNIT Porting; + +INTERFACE + +CONST pal_changed:BOOLEAN=FALSE; { Is palette changed? } + + KEYCHR_DIR1=#131; { Key codes for special keys. } + KEYCHR_DIR2=#132; + KEYCHR_DIR3=#133; + KEYCHR_DIR4=#134; + KEYCHR_DIR5=#135; + KEYCHR_DIR6=#136; + KEYCHR_DIR7=#137; + KEYCHR_DIR8=#138; + KEYCHR_DIR9=#139; + KEYCHR_CR=#13; + KEYCHR_BS=#8; + KEYCHR_TAB=#9; + +TYPE PalAry=ARRAY[0..15] OF RECORD r,g,b:BYTE END; + +PROCEDURE PutChar(x,y:BYTE;chr:CHAR;atr:BYTE); { Displays specified character on the screen. } +PROCEDURE GotoXY(x,y:BYTE); { Moves cursor. } +FUNCTION GetChr: CHAR; { Reads a key from standard input. } +PROCEDURE ChPal(Pal:PalAry); { Changes color palette, remembers the old one. } +PROCEDURE ResetPal; { Changes palette to the old one. } +PROCEDURE ScrollWin(x1,y1,x2,y2:BYTE); { Scrolls part of screen. } + +IMPLEMENTATION + +TYPE ScrChr=RECORD + chr: CHAR; + atr: BYTE; + END; + +VAR Screen: ARRAY[0..24,0..79] OF ScrChr ABSOLUTE $B800:0000; { Video memory. } + OldPal: ARRAY[0..15] OF BYTE; + OldRGB: ARRAY[0..15] OF RECORD r,g,b: BYTE END; + +PROCEDURE SetPal(i:WORD;p:BYTE);ASSEMBLER; +ASM + MOV AH, 10h + MOV AL, 00h + MOV BX, i + MOV BH, p + INT 10h +END; + +FUNCTION GetPal(i:BYTE):BYTE;ASSEMBLER; +ASM + MOV AH, 10h + MOV AL, 07h + MOV BL, i + INT 10h + MOV AL,BH +END; + +PROCEDURE GetRGB(i:WORD; VAR r,g,b: BYTE); +VAR sr,sg,sb: BYTE; +BEGIN + ASM + MOV AH, 10h + MOV AL, 15h + MOV BX, i + INT 10h + MOV sr, DH + MOV sg, CH + MOV sb, CL + END; + r:=sr; + g:=sg; + b:=sb; +END; + +PROCEDURE SetRGB(i:WORD;r,g,b:BYTE);ASSEMBLER; +ASM + MOV AH, 10h + MOV AL, 10h + MOV BX, i + MOV DH, r + MOV CH, g + MOV CL, b + INT 10h +END; + +FUNCTION GetChr: CHAR; +VAR l:CHAR; + h:BYTE; +BEGIN + ASM + MOV AH,00h + INT 16h + MOV l,AL + MOV h,AH + END; + IF l=#0 THEN CASE h OF + 71: l:=KEYCHR_DIR7; + 72: l:=KEYCHR_DIR8; + 73: l:=KEYCHR_DIR9; + + 75: l:=KEYCHR_DIR4; + 76: l:=KEYCHR_DIR5; + 77: l:=KEYCHR_DIR6; + + 79: l:=KEYCHR_DIR1; + 80: l:=KEYCHR_DIR2; + 81: l:=KEYCHR_DIR3; + END; + GetChr:=l; +END; + +PROCEDURE PutChar(x,y:BYTE;chr:CHAR;atr:BYTE); +BEGIN + IF (x>79) OR (y>24) THEN Exit; + Screen[y,x].chr:=chr; + Screen[y,x].atr:=atr; +END; + +PROCEDURE GotoXY(x,y:BYTE); +BEGIN + IF (x>79) OR (y>24) THEN Exit; + ASM + MOV AH,02h + MOV BH,00h + MOV DL,x + MOV DH,y + INT 10h + END; +END; + +PROCEDURE ChPal(Pal:PalAry); +VAR i: BYTE; +BEGIN + pal_changed:=TRUE; + FOR i:=0 TO 15 DO BEGIN + OldPal[i]:=GetPal(i); + SetPal(i,i); + GetRGB(i,OldRGB[i].r,OldRGB[i].g,OldRGB[i].b); + SetRGB(i,Pal[i].r,Pal[i].g,Pal[i].b); + END; +END; + +PROCEDURE ResetPal; +VAR i:INTEGER; +BEGIN + IF NOT pal_changed THEN Exit; + FOR i:=0 TO 15 DO BEGIN + SetPal(i,OldPal[i]); + SetRGB(i,OldRGB[i].r,OldRGB[i].g,OldRGB[i].b); + END; +END; + +PROCEDURE ScrollWin(x1,y1,x2,y2:BYTE); ASSEMBLER; +ASM + MOV AH,06h + MOV AL,01h + MOV BH,$07; + MOV CL,x1 + MOV CH,y1 + MOV DL,x2 + MOV DH,y2 + INT 10h +END; + +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/r.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,82 @@ +{ Main loop. } + +USES Global, Config, Console, Level, Light, Player, Creature, Save; + +PROCEDURE FillNills; +VAR x,y: INTEGER; + m: pMap; +BEGIN + New(mappa); + FOR y:=0 TO MAPYSIZE DO + FOR x:=0 TO MAPXSIZE DO BEGIN + m:=GetMap(x,y); + m^.slt:=NIL; + m^.crt:=NIL; + END; + FOR x:=0 TO MAXSLOT DO pc.inv[x]:=NIL; + allmonsters:=NIL; + playchr:=NIL; + gametime:=0; +END; + +PROCEDURE HandleMonsters; +VAR creat: pCreat; + i: INTEGER; +BEGIN + playchr^.mov:=0; + Play; + Inc(gametime,playchr^.mov); + + creat:=allmonsters; + WHILE creat<>NIL DO BEGIN + i:=0; + WHILE (creat^.mov<=gametime)AND (i<2) DO BEGIN + MonsterAI(creat); + Inc(i); + END; + creat:=creat^.next; + END; +END; + +PROCEDURE NewGame; +BEGIN + GeneratePlayer; + GenerateLevel; +{ TownMap;} +END; + +PROCEDURE MainMenu; +VAR l: INTEGER; + c: CHAR; +BEGIN + Cursor(79,0); + FOR l:=0 TO MAXLONGSTRING DO + IF menu_string[l]<>'' THEN Msg(menu_string[l]); + REPEAT + c:=GetKey; + UNTIL (c='n')OR(c='q'); { OR (c='l') } + ClrMsg; + CASE c OF + 'n':NewGame; + 'l':LoadGame; + 'q':BEGIN + ResetScr; + Halt; + END; + END; +END; + +BEGIN + Randomize; + FillNills; + PrepScr; + ClrMsg; + ClrTxt; + MakeLut; + ReadCfg; + MainMenu; + ShowStats; + REPEAT + HandleMonsters; + UNTIL FALSE; +END. \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/save.pas Sun Dec 08 19:39:15 2013 +0100 @@ -0,0 +1,102 @@ +{ Save and load routines. } + +UNIT save; + +INTERFACE + +USES Global; + +PROCEDURE SaveGame; +PROCEDURE LoadGame; + +IMPLEMENTATION + +USES Gzio, Strings, Console; + +CONST NL=#13+#10; + +VAR f: GzFile; + +PROCEDURE Sav(s:STRING); +VAR t: pChar; +BEGIN + s:=Concat(s,NL); + GzWrite(f,@(s[1]),Length(s)); +END; + +PROCEDURE SavePlayer; +BEGIN + Sav('# Player character info:'); + Sav('# ----------------------'); + Sav(Concat('CHAR_ID ',playchr^.def^.nam)); + Sav(Concat('CHAR_HP ',Num(playchr^.hp),' ',Num(playchr^.def^.hp))); + Sav(Concat('CHAR_POSITION ',Num(playchr^.x),' ',Num(playchr^.y))); +END; + +PROCEDURE SaveLevel; +BEGIN + Sav('# Level info:'); + Sav('# -----------'); + +END; + +PROCEDURE SaveKnowledge; +BEGIN + Sav('# Items knowledge:'); + Sav('# -----------'); +END; + +PROCEDURE SaveItems; +BEGIN + Sav('# Items info:'); + Sav('# -----------'); +END; + +PROCEDURE SaveMonsters; +VAR p: pCreat; +BEGIN + Sav('# Creatures info:'); + Sav('# ---------------'); + p:=allmonsters; + WHILE p<>NIL DO BEGIN + Sav(Concat('MONSTER ',Num(p^.def^.id),' # ',p^.def^.nam)); + Sav(Concat('MON_POSITION ',Num(p^.x),' ',Num(p^.x))); + Sav(Concat('MON_HP ',Num(p^.hp))); + Sav(Concat('MON_NEXTMOVE ',Num(p^.mov))); + p:=p^.next; + END; +END; + + +PROCEDURE SaveGame; +BEGIN + Msg(msgs[34]); + + f:=GzOpen('savegame.gz','wf'); + IF f=NIL THEN Exit; + + Sav('# This is save file.'); + Sav('# =================='); + + Sav(Concat('VERSION "',VERSION,'"')); + + SavePlayer; + SaveKnowledge; + SaveItems; + SaveMonsters; + SaveLevel; + + + Sav('# End of file.'); + Sav('# ------------'); + Sav('END'); + + GzFlush(f,1); + GzClose(f); +END; + +PROCEDURE LoadGame; +BEGIN +END; + +END. \ No newline at end of file