procedure clearinputbuffer; var regs : Registers; begin with regs do begin ah := $0C; al := $00; msdos (regs); end; end; procedure ReadKbd (var Keys : KeyType); var regs : Registers; begin { ReadKbd } regs.di := $06; { set up to read keyboard } intr ($18,regs); { lets read it } if regs.al <= $65 then Keys.Fun_Key := F_Keys[regs.al]; { assign function key type name } end; { ReadKbd } procedure GetEnvParam (EnvName : string80; var param : string80); var I : integer; EnvSeg, { segment address of environment from PSP } EnvIndex : integer; { index into environment } TempName : string80; { current environment string name } ch : char; { current character from environment } found : boolean; { if true then environment name was found } begin { GetEnvParam } for I := 1 to length(EnvName) do EnvName[I] := upcase(EnvName[I]); EnvIndex := 0; EnvSeg := MemW[CSeg:$2C]; { get address of environment from PSP } found := false; ch := chr(Mem[EnvSeg:EnvIndex]); { get first char from environment } while (ch <> chr(0)) and (not found) do begin TempName := ''; while (ch <> '=') and (length(TempName) < 255) do begin { get environment string name } TempName := TempName + ch; EnvIndex := EnvIndex + 1; ch := chr(Mem[EnvSeg:EnvIndex]) end; EnvIndex := EnvIndex + 1; { skip over the EQUALS } param := ''; ch := chr(Mem[EnvSeg:EnvIndex]); while ch <> chr(0) do { get environment string parameter } begin param := param + ch; EnvIndex := EnvIndex + 1; ch := chr(Mem[EnvSeg:EnvIndex]) end; found := EnvName = TempName; EnvIndex := EnvIndex + 1; ch := chr(Mem[EnvSeg:EnvIndex]) end; if not found then param := '' end; { GetEnvParam } procedure CreateNewTopTenFile; begin rewrite (TopTenFile); fillchar (TopTenRecord, 384, 0); blockwrite (TopTenFile, TopTenRecord, 3); seek (TopTenFile, 0); end; procedure GetSystemDate; var regs : registers; day : string[2]; month : string[2]; year : string[4]; begin with regs do begin ah := $2A; msdos (regs); str (dl:2, day); str (dh:2, month); str (cx:4, year); ScoreDate := day+'.'+month+'.'+year[3]+year[4]; end; end; procedure printtopten; begin writeln (^[, '[H', ^[, '[J'); writeln; writeln (^[, '#3 Pacman TopTen Liste'); writeln (^[, '#4 Pacman TopTen Liste'); writeln; writeln; writeln (' Name Punkte Datum'); writeln; for i := 0 to 9 do begin move (TopTenRecord[32*i+1], name, 20); move (TopTenRecord[32*i+21], Pointshi, 2); move (TopTenRecord[32*i+23], Pointslo, 2); move (TopTenRecord[32*i+25], ScoreDate, 8); if TopTenRecord[32*i+1] > 0 then begin if i = lines-1 then write (^[, '[5m'); write (' ',name, ' '); if Pointshi = 0 then write (' ') else write (Pointshi:5); if Pointshi > 0 then begin if Pointslo = 0 then writeln ('0000 ', ScoreDate) else if Pointslo < 10 then writeln ('00', Pointslo*10:2, ' ', ScoreDate) else if Pointslo < 100 then writeln ('0', Pointslo*10:3, ' ', ScoreDate) else writeln (Pointslo*10:4, ' ', ScoreDate); end else writeln (Pointslo*10:4, ' ', ScoreDate); if i = lines-1 then write (^[, '[0m'); end else writeln; end; writeln; writeln; end; procedure TopTen; begin writeln (^[, '[H', ^[, '[J', ^[, '[0m'); GraphicsOff; GetEnvParam ('PACMAN', parameter); if parameter = '' then parameter := 'pacman.tmp'; assign (TopTenFile, parameter); {$I-} reset (TopTenFile); {$I+} if IOResult <> 0 then CreateNewTopTenFile; blockread (TopTenFile, TopTenRecord, 3); lines := 0; scoreaddon := scoreaddon+100*scorecarry; inserted := false; repeat move (TopTenRecord[32*lines+21], Pointshi, 2); move (TopTenRecord[32*lines+23], Pointslo, 2); if (Pointshi < scoreaddon) or ((Pointshi = scoreaddon) and (Pointslo < score)) then begin write ('Ihr werter Name : '); readln (name); GetSystemDate; move (TopTenRecord[32*lines+1], TopTenRecord[32*lines+33], 352-32*lines); move (name, TopTenRecord[32*lines+1], 20); move (scoreaddon, TopTenRecord[32*lines+21], 2); move (score, TopTenRecord[32*lines+23], 2); move (ScoreDate, TopTenRecord[32*lines+25], 8); inserted := true; end; lines := lines+1; until (lines = 10) or inserted; if inserted then begin seek (TopTenFile, 0); blockwrite (TopTenFile, TopTenRecord, 3); end else lines := 11; close (TopTenFile); printtopten; end; procedure InitGraphics; var p : integer; begin { required initialization } { red --+ green --+ } { |+-- mono |+-- blue } { || || } ColorMap[00]:=$00; ColorMap[16]:=$00; { 0 black } ColorMap[01]:=$0E; ColorMap[17]:=$F0; { 1 green } ColorMap[02]:=$FD; ColorMap[18]:=$06; { 2 red } ColorMap[03]:=$FC; ColorMap[19]:=$0F; { 3 red-violet } ColorMap[04]:=$8B; ColorMap[20]:=$0B; { 4 purple } ColorMap[05]:=$BA; ColorMap[21]:=$75; { 5 brown } ColorMap[06]:=$F8; ColorMap[22]:=$F0; { 6 yellow } ColorMap[07]:=$FF; ColorMap[23]:=$FF; { 7 white } ColorMap[08]:=$00; ColorMap[24]:=$00; { 8 switched1 } ColorMap[09]:=$00; ColorMap[25]:=$00; { 9 switched2 } ColorMap[10]:=$97; ColorMap[26]:=$02; { 10 dark red } ColorMap[11]:=$F6; ColorMap[27]:=$70; { 11 orange } ColorMap[12]:=$05; ColorMap[28]:=$0F; { 12 blue } ColorMap[13]:=$04; ColorMap[29]:=$FD; { 13 turquoise } ColorMap[14]:=$B3; ColorMap[30]:=$16; { 14 burgandy } ColorMap[15]:=$F2; ColorMap[31]:=$BB; { 15 pink } { Note. The colors of the table above have been selected so that: * plane 0 turns on the green gun * plane 1 turns on the red gun * plane 2 turns on the blue gun * plane 3 causes a darkening and reddening of the other colors But any other criteria is allowed.} for p := 0 to 255 do ScrollMap[p] := p; HighResolution:=false; { Change to 'true' for high resolution demo } Ginitialize; { Initialize } DualMonitor:=false; { Dual CRTs } { end of required initialization } LoadScrollMap(ScrollMap); LoadColorMap(ColorMap); { Load color map } Operation(0,15); { REPLACE write to all planes } Pattern(255,4); { Draw all lines as solid lines } fillchar(plane0,11520,0); fillchar(plane1,11520,0); fillchar(plane2,11520,0); fillchar(plane3,11520,0); WriteRectangle(0,maxx,0,maxy,plane0); GraphicsOn; { Switch from VT102 to graphics drive } end; procedure initializedigits; var j : integer; i : integer; begin for j := 0 to 9 do for i := 0 to 10 do begin digit[i+2*11*j+11] := (digitarray[i+11*j] shl 11) or (digitarray[i+11*j] shr 5); digit[i+2*11*j] := digitarray[i+11*j] shl 3; end; end; procedure writescoredigit (scoredigit, xkoord, digitcount : integer); var r : integer; i : integer; p : integer; const ystart : integer = 20; yend : integer = 30; begin r := (scoredigit shl 4)+(scoredigit shl 2)+(scoredigit shl 1); p := ((xkoord and $FFF0) shl 4) - (xkoord and $FFF0); if not odd(digitcount) then begin r := r+11; for i := ystart to yend do begin plane0[p+i] := digit[r]; (* digit[r] Fehler ??? *) r := r+1; end; color (white); WriteRectangleOneByte (xkoord, ystart, yend, plane0, $F80F, p); end else begin for i := ystart to yend do begin plane0[p+i] := digit[r]; (* digit[r] Fehler ??? *) plane0[p+i+240] := plane0[p+i]; r := r+1; end; color (white); WriteRectangleTwoBytes (xkoord, ystart, yend, plane0, $FFF8, $07FF, p); end; end; procedure writescore (scorevalue, digitplace, digitstart : integer); var scoredigit : integer; scorexkoord : integer; digitcount : integer; begin scorexkoord := digitplace+(digitwidth shl 2); digitcount := digitstart; repeat digitcount := digitcount+1; scoredigit := scorevalue mod 10; scorevalue := scorevalue div 10; writescoredigit (scoredigit, scorexkoord, digitcount); scorexkoord := scorexkoord-digitwidth; until scorevalue = 0; end; procedure producebullets; var i : integer; j : integer; i4 : integer; vert : integer; hori : integer; begin for i := 0 to 16 do begin if odd(i) then begin bulletsplane[2*i+1] := $AAAA; bulletsplane[2*i+2] := $AAA8; end else begin bulletsplane[2*i+1] := $FFFF; bulletsplane[2*i+2] := $FFF8; end; end; for i := 0 to 8 do begin i4 := 4*i+1; vert := verticallines[i]; for j := 0 to 7 do begin vert := vert shl 1; if (vert and $8000) <> 0 then bulletsplane[i4] := bulletsplane[i4] and not($8000 shr (2*j+1)); end; for j := 0 to 7 do begin vert := vert shl 1; if (vert and $8000) <> 0 then bulletsplane[i4+1] := bulletsplane[i4+1] and not($8000 shr (2*j+1)); end; end; for i := 0 to 7 do begin i4 := 4*i+3; hori := horizontallines[i+1]; for j := 0 to 7 do begin if (hori and $8000) <> 0 then bulletsplane[i4] := bulletsplane[i4] and not($8000 shr (2*j)); hori := hori shl 1; end; for j := 0 to 7 do begin if (hori and $8000) <> 0 then bulletsplane[i4+1] := bulletsplane[i4+1] and not($8000 shr (2*j)); hori := hori shl 1; end; end; for i := 1 to 9 do for j := 1 to 15 do begin if gethomefast[(i-1)*15+j] = 0 then begin if j = 1 then begin if i > 1 then bulletsplane[4*i-5] := bulletsplane[4*i-5] and $3FFF; bulletsplane[4*i-3] := bulletsplane[4*i-3] and $3FFF; if i < 9 then bulletsplane[4*i-1] := bulletsplane[4*i-1] and $3FFF; end else if j < 9 then begin if i > 1 then bulletsplane[4*i-5] := bulletsplane[4*i-5] and not($E000 shr (2*j-3)); bulletsplane[4*i-3] := bulletsplane[4*i-3] and not($E000 shr (2*j-3)); if i < 9 then bulletsplane[4*i-1] := bulletsplane[4*i-1] and not($E000 shr (2*j-3)); end else if j = 9 then begin if i > 1 then begin bulletsplane[4*i-4] := bulletsplane[4*i-4] and $3FF8; bulletsplane[4*i-5] := bulletsplane[4*i-5] and $FFFE; end; bulletsplane[4*i-2] := bulletsplane[4*i-2] and $3FF8; bulletsplane[4*i-3] := bulletsplane[4*i-3] and $FFFE; if i < 9 then begin bulletsplane[4*i] := bulletsplane[4*i] and $3FF8; bulletsplane[4*i-1] := bulletsplane[4*i-1] and $FFFE; end; end else begin if i > 1 then bulletsplane[4*i-4] := bulletsplane[4*i-4] and not($E000 shr (2*j-19)); bulletsplane[4*i-2] := bulletsplane[4*i-2] and not($E000 shr (2*j-19)); if i < 9 then bulletsplane[4*i] := bulletsplane[4*i] and not($E000 shr (2*j-19)); end; end; end; bulletsplane[17] := bulletsplane[17] and $FFE3; bulletsplane[18] := bulletsplane[18] and $8FF8; end; procedure producegamelayout; var i : integer; j : integer; count : integer; begin fillchar (layoutpacman,1350,0); for j := 0 to 8 do for i := 1 to 15 do begin count := 0; if ((verticallines[j] shl (i-1)) and $8000) = 0 then begin count := count+1; layoutpacman[75*j+5*i-4+count] := 2; end; if ((verticallines[j] shl i) and $8000) = 0 then begin count := count+1; layoutpacman[75*j+5*i-4+count] := -2; end; if ((horizontallines[j] shl (i-1)) and $8000) = 0 then begin count := count+1; layoutpacman[75*j+5*i-4+count] := 1; end; if ((horizontallines[j+1] shl (i-1)) and $8000) = 0 then begin count := count+1; layoutpacman[75*j+5*i-4+count] := -1; end; layoutpacman[75*j+5*i-4] := count; end; layoutpacman[326] := layoutpacman[326]-1; for i := 327 to 330 do if layoutpacman[i] = -2 then begin for j := i to 329 do layoutpacman[j] := layoutpacman[j+1]; layoutpacman[330] := 0; end; move (layoutpacman,layoutenemy,1350); end; procedure producegethomefast; var i : integer; j : integer; k : integer; index : integer; gethometemp : array [1..135] of integer; changed : boolean; begin producegamelayout; fillchar (gethometemp,270,0); gethometemp[66] := -2; repeat move (gethometemp,gethomefast,270); changed := false; for i := 1 to 9 do begin for j := 1 to 15 do begin if gethomefast[(i-1)*15+j] <> 0 then begin for k := 1 to layoutpacman[((i-1)*15+j-1)*5+1] do begin case layoutpacman[((i-1)*15+j-1)*5+1+k] of 1 : begin index := ((i-2)*15+j) mod 135; if index <= 0 then index := index+135; if gethomefast[index] = 0 then begin gethometemp[index] := -1; changed := true; end; end; -1 : begin index := (i*15+j) mod 135; if index <= 0 then index := index+135; if gethomefast[index] = 0 then begin gethometemp[index] := 1; changed := true; end; end; 2 : begin if gethomefast[(i-1)*15+j-1] = 0 then begin gethometemp[(i-1)*15+j-1] := -2; changed := true; end; end; -2 : begin if gethomefast[(i-1)*15+j+1] = 0 then begin gethometemp[(i-1)*15+j+1] := 2; changed := true; end; end; end; end; end; end; end; until not changed; end; procedure produceverticalline (vert, mask, posit, lineval, line : integer); var j : integer; begin if (vert and mask) <> 0 then begin plane0[240*posit+23*line] := plane0[240*posit+23*line] or lineval; for j := 1 to 22 do plane0[240*posit+23*line+j] := lineval; plane0[240*posit+23*(line+1)] := plane0[240*posit+23*(line+1)] or lineval; end; end; procedure producehorizontalline (horiz, mask, posit, lineval1, lineval2, lineval3, line : integer); begin if (horiz and mask) <> 0 then begin plane0[240*posit+23*line] := plane0[240*posit+23*line] or lineval1; plane0[240*(posit+1)+23*line] := lineval2; if lineval3 <> $0000 then plane0[240*(posit+2)+23*line] := lineval3; end; end; procedure CheckForEnclosedPowerPill; begin if gethomefast[17] = 0 then begin if gethomefast[2] <> 0 then horizontallines[1] := horizontallines[1] and $BFFF else if gethomefast[32] <> 0 then horizontallines[2] := horizontallines[2] and $BFFF else if gethomefast[16] <> 0 then verticallines[1] := verticallines[1] and $BFFF else if gethomefast[18] <> 0 then verticallines[1] := verticallines[1] and $DFFF; end; if gethomefast[29] = 0 then begin if gethomefast[14] <> 0 then horizontallines[1] := horizontallines[1] and $FFFA else if gethomefast[44] <> 0 then horizontallines[2] := horizontallines[2] and $FFFA else if gethomefast[13] <> 0 then verticallines[1] := verticallines[1] and $FFFB else if gethomefast[15] <> 0 then verticallines[1] := verticallines[1] and $FFFD; end; if gethomefast[121] = 0 then begin if gethomefast[106] <> 0 then horizontallines[8] := horizontallines[8] and $7FFF else if (gethomefast[106] = 0) and (gethomefast[91] <> 0) then begin horizontallines[8] := horizontallines[8] and $7FFF; horizontallines[7] := horizontallines[7] and $7FFF; end else if gethomefast[122] <> 0 then verticallines[8] := verticallines[8] and $BFFF else if (gethomefast[122] = 0) and (gethomefast[123] <> 0) then verticallines[8] := verticallines[8] and $9FFF; end; if gethomefast[134] = 0 then begin if gethomefast[119] <> 0 then horizontallines[8] := horizontallines[8] and $FFFA else if gethomefast[133] <> 0 then verticallines[8] := verticallines[8] and $FFFB else if gethomefast[135] <> 0 then verticallines[8] := verticallines[8] and $FFFD; end; end; function NullNeighbours : integer; var i : integer; j : integer; countmax : integer; nulls : array [1..135] of integer; begin countmax := 0; fillchar (nulls,270,0); for i := 1 to 135 do if gethomefast[i] = 0 then nulls[i] := 1; for i := 1 to 120 do if (nulls[i] > 0) and (nulls[i+15] > 0) then nulls[i+15] := nulls[i+15]+nulls[i]; for i := 135 downto 16 do if (nulls[i] > 0) and (nulls[i-15] > 0) then nulls[i-15] := nulls[i]; for i := 1 to 135 do if (i mod 15) > 0 then begin if (nulls[i] > 0) and (nulls[i+1] > 0) then nulls[i+1] := nulls[i+1]+nulls[i]; if nulls[i] > countmax then countmax := nulls[i]; end; NullNeighbours := countmax; end; procedure generatepicturelayout; var i : integer; j : integer; linecount : integer; probab : integer; trycount : integer; const probab1 : integer = 30; probab2 : integer = 15; probab3 : integer = 5; probab4 : integer = 2; begin j := random(15); if j < 7 then begin for i := 0 to 9 do horizontallines[i] := horizontallinesconst[i+j*10]; for i := 0 to 8 do verticallines[i] := verticallinesconst[i+j*9]; end else begin repeat fillchar (horizontallines,20,0); for i := 0 to 8 do verticallines[i] := $8001; horizontallines[0] := $FEFE; horizontallines[4] := $0200; horizontallines[5] := $0200; horizontallines[9] := $FEFE; verticallines[4] := $8161; for i := 0 to 15 do for j := 0 to 9 do begin probab := random(probab1+probab2+probab3+probab4); if probab < probab1 then probab := 1 else if probab < probab1+probab2 then probab := 2 else if probab < probab1+probab2+probab3 then probab := 3 else probab := 4; linecount := 0; if i > 0 then begin if (horizontallines[j] and ($8000 shr (i-1))) <> 0 then linecount := linecount+1; end; if i < 15 then begin if (horizontallines[j] and ($8000 shr i)) <> 0 then linecount := linecount+1; end; if j > 0 then begin if (verticallines[j-1] and ($8000 shr i)) <> 0 then linecount := linecount+1; end; if j < 9 then begin if (verticallines[j] and ($8000 shr i)) <> 0 then linecount := linecount+1; end; trycount := 0; while (linecount < probab) and ((linecount = 0) or (trycount < 20)) do begin case random(2) of 0 : if (i < 14) or ((i < 15) and (random(2) < 1)) then begin horizontallines[j] := horizontallines[j] or ($8000 shr i); linecount := linecount+1; end; 1 : if (j < 8) or ((j < 9) and (random(2) < 1)) then begin verticallines[j] := verticallines[j] or ($8000 shr i); linecount := linecount+1; end; end; trycount := trycount+1; end; end; horizontallines[0] := $FEFE; horizontallines[4] := horizontallines[4] or $0040; horizontallines[5] := horizontallines[5] or $0040; horizontallines[9] := $FEFE; verticallines[4] := verticallines[4] and $FDFF; producegethomefast; until (NullNeighbours < 4) and (gethomefast[55] <> 0) and (gethomefast[85] <> 0); CheckForEnclosedPowerPill; end; horizontallines[4] := horizontallines[4] or $0040; horizontallines[5] := horizontallines[5] or $0040; producegethomefast; move (gethomefast,gethome,270); horizontallines[4] := horizontallines[4] and $FFBE; horizontallines[5] := horizontallines[5] and $FFBE; producegethomefast; end; procedure initgamelayout; var i : integer; j : integer; horizontal : integer; vertical : integer; begin generatepicturelayout; for i := 0 to 20 do for j := 0 to 207 do plane0[240*i+j] := $0000; for i := 0 to 9 do begin horizontal := horizontallines[i]; producehorizontalline (horizontal,$8000,0,$FFFF,$00FE,$0000,i); producehorizontalline (horizontal,$4000,1,$FF03,$F8FF,$0000,i); producehorizontalline (horizontal,$2000,2,$0F00,$FFFF,$00E0,i); producehorizontalline (horizontal,$1000,4,$FF3F,$80FF,$0000,i); producehorizontalline (horizontal,$0800,5,$FF00,$FEFF,$0000,i); producehorizontalline (horizontal,$0400,6,$0300,$FFFF,$00F8,i); producehorizontalline (horizontal,$0200,8,$FF0F,$E0FF,$0000,i); producehorizontalline (horizontal,$0100,9,$3F00,$FFFF,$0080,i); producehorizontalline (horizontal,$0080,11,$FFFF,$00FE,$0000,i); producehorizontalline (horizontal,$0040,12,$FF03,$F8FF,$0000,i); producehorizontalline (horizontal,$0020,13,$0F00,$FFFF,$00E0,i); producehorizontalline (horizontal,$0010,15,$FF3F,$80FF,$0000,i); producehorizontalline (horizontal,$0008,16,$FF00,$FEFF,$0000,i); producehorizontalline (horizontal,$0004,17,$0300,$FFFF,$00F8,i); producehorizontalline (horizontal,$0002,19,$FF0F,$E0FF,$0000,i); end; for i := 0 to 8 do begin vertical := verticallines[i]; produceverticalline (vertical,$8000,0,$0080,i); produceverticalline (vertical,$4000,1,$0002,i); produceverticalline (vertical,$2000,2,$0800,i); produceverticalline (vertical,$1000,4,$0020,i); produceverticalline (vertical,$0800,5,$8000,i); produceverticalline (vertical,$0400,6,$0200,i); produceverticalline (vertical,$0200,8,$0008,i); produceverticalline (vertical,$0100,9,$2000,i); produceverticalline (vertical,$0080,11,$0080,i); produceverticalline (vertical,$0040,12,$0002,i); produceverticalline (vertical,$0020,13,$0800,i); produceverticalline (vertical,$0010,15,$0020,i); produceverticalline (vertical,$0008,16,$8000,i); produceverticalline (vertical,$0004,17,$0200,i); produceverticalline (vertical,$0002,19,$0008,i); produceverticalline (vertical,$0001,20,$2000,i); end; plane0[240*20+0] := plane0[240*20+0] or $1F00; plane0[240*20+207] := plane0[240*20+207] or $1F00; producebullets; ColorMap[10] := $00; ColorMap[26] := $00; LoadColorMap(ColorMap); color(switch3); for i := 47 to 57 do plane0[240*8+2*i] := $0008; (* Enemy-Gatter *) WriteRectangle(1,maxx-54,1,206,plane0); ColorMap[10] := $FF; ColorMap[26] := $FF; LoadColorMap(ColorMap); closed := false; end; procedure produceframe; begin for i := 0 to 23 do begin plane0[240*i+0] := $FFFF; plane0[240*i+207] := $FFFF; end; plane0[240*9+0] := $E0FF; plane0[240*9+207] := $E0FF; plane0[240*10+0] := $0000; plane0[240*10+207] := $0000; for i := 1 to 206 do begin plane0[240*0+i] := $0080; plane0[240*20+i] := $2000; plane0[240*23+i] := $0100; end; ColorMap[09] := $00; ColorMap[25] := $00; LoadColorMap(ColorMap); color(switch2); WriteRectangle(0,maxx,0,0,plane0); WriteRectangle(0,maxx,207,207,plane0); WriteRectangle(0,0,0,207,plane0); WriteRectangle(maxx-53,maxx,1,maxy-1,plane0); ColorMap[09] := $FF; ColorMap[25] := $FF; end; procedure generatefigur (figurtype, xkoord, ykoord : integer); begin case figurtype of 1 : begin r := 240*(xkoord shr 4); s := 20*(xkoord and $F); move(pacman[s],plane1[r+ykoord],20); move(pacman[s+10],plane1[r+240+ykoord],20); end; 2 : begin r := 240*(xkoord shr 4)+ykoord; s := 20*(xkoord and $F); move(enemy[s],plane1[r],20); move(enemy[s+10],plane1[r+240],20); end; end; end; procedure erasefruit; var i : integer; begin fruitdisplay := false; fruitend := fruitend+1; if closed then begin layoutenemy[271] := layoutenemy[271]+1; layoutenemy[271+layoutenemy[271]] := -1; layoutenemy[421] := layoutenemy[421]+1; layoutenemy[421+layoutenemy[421]] := 1; end; closed := false; for i := 94 to 114 do begin plane0[240*13+i] := $0000; plane0[240*12+i] := $0000; end; writerectangle (199,219,94,114,plane0); end; procedure initfruit; var i : integer; j : integer; fruitpos : integer; begin fruitpos := ((fruitnr-1) mod 10)+1; j := 94; i := (fruitpos-1)*42; repeat plane0[240*12+j] := fruitarray[i]; plane0[240*13+j] := fruitarray[i+1]; plane0[240*2*(fruitpos-1)+j+121] := fruitarray[i]; plane0[240*(2*(fruitpos-1)+1)+j+121] := fruitarray[i+1]; i := i+2; j := j+1; until i = fruitpos*42; end; procedure displayfruit (where : integer); var i : integer; j : integer; fruitpos : integer; xlo : integer; xhi : integer; ylo : integer; yhi : integer; begin fruitpos := ((fruitnr-1) mod 10)+1; if where = 0 then begin xlo := 199; xhi := 219; ylo := 94; yhi := 114; end else begin xlo := 7+((fruitpos-1) shl 5); xhi := xlo+20; ylo := 215; yhi := 235; if fruitpos = 1 then writerectangle (0,maxx,215,235,plane1); end; case fruitpos of 1 : (* Birne *) begin Color (green); writerectangle (xlo,xhi,ylo+6,yhi,plane0); Color (brown); writerectangle (xlo,xhi,ylo,ylo+5,plane0); writerectangle (xlo+9,xlo+9,ylo+6,ylo+6,plane0); end; 2 : (* Ananas *) begin Color (green); writerectangle (xlo,xhi,ylo,ylo+5,plane0); Color (brown); writerectangle (xlo,xhi,ylo+6,yhi,plane0); end; 3 : (* Zitrone *) begin color (yellow); writerectangle (xlo,xhi,ylo,yhi,plane0); end; 4 : (* Kokosnuß *) begin color (brown); writerectangle (xlo,xhi,ylo+9,yhi,plane0); color (white); writerectangle (xlo,xhi,ylo,ylo+8,plane0); writerectangle (xlo+3,xlo+16,ylo+9,ylo+9,plane0); writerectangle (xlo+5,xlo+14,ylo+10,ylo+10,plane0); writerectangle (xlo+8,xlo+11,ylo+11,ylo+11,plane0); end; 5 : (* Pflaume *) begin color (brown); writerectangle (xlo,xhi,ylo,ylo+7,plane0); color (purple); writerectangle (xlo,xhi,ylo+8,yhi,plane0); end; 6 : (* Erdbeere *) begin color (red); writerectangle (xlo,xhi,ylo,yhi,plane0); color (green); writerectangle (xlo+9,xlo+11,ylo,ylo+6,plane0); Color (white); writerectangle (xlo+13,xlo+13,ylo+7,ylo+7,plane0); writerectangle (xlo+8,xlo+8,ylo+8,ylo+8,plane0); writerectangle (xlo+11,xlo+11,ylo+8,ylo+8,plane0); writerectangle (xlo+9,xlo+9,ylo+10,ylo+10,plane0); writerectangle (xlo+13,xlo+13,ylo+10,ylo+10,plane0); writerectangle (xlo+11,xlo+11,ylo+12,ylo+12,plane0); writerectangle (xlo+9,xlo+9,ylo+13,ylo+13,plane0); writerectangle (xlo+10,xlo+10,ylo+15,ylo+15,plane0); end; 7 : (* Weintraube *) begin color (brown); writerectangle (xlo,xhi,ylo,ylo+4,plane0); Color (green); writerectangle (xlo,xhi,ylo+5,yhi,plane0); end; 8 : (* Banane *) begin color (yellow); writerectangle (xlo,xhi,ylo,yhi,plane0); end; 9 : (* Apfelsine *) begin color (orange); writerectangle (xlo,xhi,ylo+2,yhi,plane0); Color (green); writerectangle (xlo,xhi,ylo,ylo+1,plane0); writerectangle (xlo+9,xlo+10,ylo+2,ylo+2,plane0); end; 10 : (* Kirsche *) begin color (red); writerectangle (xlo,xhi,ylo+8,yhi,plane0); Color (green); writerectangle (xlo,xhi,ylo,ylo+7,plane0); writerectangle (xlo+9,xlo+10,ylo+8,ylo+8,plane0); end; end; end; procedure movepacman (direction : integer); var i : integer; p : integer; q : integer; s : integer; s1 : integer; r240 : integer; r248 : integer; r239 : integer; r241 : integer; eater : integer; begin if fruitdisplay then begin fruitend := fruitend+1; end; if PowerPill > 0 then begin movecount := movecount+1; eater := 320; color (green); end else begin eater := 0; color (yellow); end; case direction of 0 : (* no movement *) begin r240 := ((xkoordpacman and $FFF0) shl 4)- (xkoordpacman and $FFF0); r241 := r240+240; s := xkoordpacman and $F; q := (s shl 4)+(s shl 2)+eater; move(pacman[q],plane1[r240+ykoordpacman],20); if s > 8 then begin move(pacman[q+10],plane1[r241+ykoordpacman],20); WriteRectangleTwoBytes (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, mask5[s], mask6[s], r240); end else WriteRectangleOneByte (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, mask4[s], r240); end; 1 : (* up *) begin r240 := ((xkoordpacman and $FFF0) shl 4)- (xkoordpacman and $FFF0); r241 := r240+240; s := xkoordpacman and $F; q := (s shl 4)+(s shl 2)+eater; if (ykoordpacman-1 >= 0) and (ykoordpacman-1 < 198) then begin move(pacman[q],plane1[r240+ykoordpacman-1],20); ykoordpacman := ykoordpacman-1; if s > 8 then begin move(pacman[q+10],plane1[r241+ykoordpacman],20); WriteRectangleTwoBytes (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, mask5[s], mask6[s], r240); Color(white); WriteRectangleTwoBytes (xkoordpacman, ykoordpacman+10, ykoordpacman+10, plane3, mask5[s], mask6[s], r240); end else begin WriteRectangleOneByte (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, mask4[s], r240); Color(white); WriteRectangleOneByte (xkoordpacman, ykoordpacman+10, ykoordpacman+10, plane3, mask4[s], r240); end; end else begin if ykoordpacman >= 198 then ykoordpacman := ykoordpacman-208; for p := ykoordpacman-1 to -2 do begin plane1[r240+p+208] := pacman[q]; q := q+1; end; plane1[r240+207] := pacman[q]; q := q+1; for p := 0 to ykoordpacman+8 do begin plane1[r240+p] := pacman[q]; q := q+1; end; WriteRectangle(xkoordpacman, xkoordpacman+6, ykoordpacman+207, 207, plane1); WriteRectangle(xkoordpacman, xkoordpacman+6, 0, ykoordpacman+8, plane1); Color(white); WriteRectangle(xkoordpacman, xkoordpacman+6, ykoordpacman+9, ykoordpacman+9, plane3); ykoordpacman := ykoordpacman-1; if ykoordpacman = -10 then ykoordpacman := 198; (* 207-10+1 *) end; end; -1 : (* down *) begin r240 := ((xkoordpacman and $FFF0) shl 4)- (xkoordpacman and $FFF0); r241 := r240+240; s := xkoordpacman and $F; q := (s shl 4)+(s shl 2)+eater; if (ykoordpacman+10 < 208) and (ykoordpacman >= 0) then begin move(pacman[q],plane1[r240+ykoordpacman+1],20); ykoordpacman := ykoordpacman+1; if s > 8 then begin move(pacman[q+10],plane1[r241+ykoordpacman],20); WriteRectangleTwoBytes (xkoordpacman, ykoordpacman-1, ykoordpacman+9, plane1, mask5[s], mask6[s], r240); Color(white); WriteRectangleTwoBytes (xkoordpacman, ykoordpacman-1, ykoordpacman-1, plane3, mask5[s], mask6[s], r240); end else begin WriteRectangleOneByte (xkoordpacman, ykoordpacman-1, ykoordpacman+9, plane1, mask4[s], r240); Color(white); WriteRectangleOneByte (xkoordpacman, ykoordpacman-1, ykoordpacman-1, plane3, mask4[s], r240); end; end else begin if ykoordpacman <= 0 then ykoordpacman := ykoordpacman+208; q := q+9; for p := ykoordpacman+10 downto 209 do begin plane1[r240+p-208] := pacman[q]; q := q-1; end; plane1[r240] := pacman[q]; q := q-1; for p := 207 downto ykoordpacman+1 do begin plane1[r240+p] := pacman[q]; q := q-1; end; WriteRectangle(xkoordpacman, xkoordpacman+6, 0, ykoordpacman-198, plane1); WriteRectangle(xkoordpacman, xkoordpacman+6, ykoordpacman+1, 207, plane1); Color(white); WriteRectangle(xkoordpacman, xkoordpacman+6, ykoordpacman, ykoordpacman, plane3); ykoordpacman := ykoordpacman+1; if ykoordpacman = 208 then ykoordpacman := 0; end; end; 2 : (* left *) begin xkoordpacman := xkoordpacman-1; r240 := ((xkoordpacman and $FFF0) shl 4)- (xkoordpacman and $FFF0); r241 := r240+240; r248 := (((xkoordpacman+7) and $FFF0) shl 4)- ((xkoordpacman+7) and $FFF0); s := xkoordpacman and $F; q := (s shl 4)+(s shl 2)+eater; move(pacman[q],plane1[r240+ykoordpacman],20); s1 := (xkoordpacman+7) and $F; if s > 8 then begin move(pacman[q+10],plane1[r241+ykoordpacman],20); WriteRectangleTwoBytes (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, mask5[s], mask6[s], r240); end else WriteRectangleOneByte (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, mask4[s], r240); Color(white); WriteRectangleOneByte (xkoordpacman+7, ykoordpacman, ykoordpacman+9, plane3, maskleft[s1], r248); end; -2 : (* right *) begin xkoordpacman := xkoordpacman+1; r240 := ((xkoordpacman and $FFF0) shl 4)- (xkoordpacman and $FFF0); r241 := r240+240; r239 := r240-240; s := xkoordpacman and $F; q := (s shl 4)+(s shl 2)+eater; if s = 0 then begin move(pacman[q],plane1[r240+ykoordpacman],20); WriteRectangleOneByte (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, $01FF, r240); Color(white); WriteRectangleOneByte (xkoordpacman-1, ykoordpacman, ykoordpacman+9, plane3, maskright[15], r239); end else begin move(pacman[q],plane1[r240+ykoordpacman],20); if s > 8 then begin move(pacman[q+10],plane1[r241+ykoordpacman],20); WriteRectangleTwoBytes (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, mask5[s], mask6[s], r240); end else WriteRectangleOneByte (xkoordpacman, ykoordpacman, ykoordpacman+9, plane1, mask4[s], r240); s := (s-1) and $F; Color(white); WriteRectangleOneByte (xkoordpacman-1, ykoordpacman, ykoordpacman+9, plane3, maskright[s], r240); end; end; end; if (direction <> 0) and (ykoordpacman > 0) then begin s := ykoordpacman mod 23; if s = 7 then s := ykoordpacman+4 else if s = 18 then s := ykoordpacman+5 else s := -1; if s > 0 then begin r240 := (((xkoordpacman+3) and $FFF0) shl 4)- ((xkoordpacman+3) and $FFF0); r241 := r240+240; q := (xkoordpacman+3) div 11; if ((plane3[r240+s] and dots[q]) <> 0) and ((xkoordpacman mod 11) = 8) then begin bullets := bullets+1; plane3[r240+s] := plane3[r240+s] and not dots[q]; plane3[r240+s+1] := plane3[r240+s]; if dots[q] = $0100 then begin plane3[r241+s] := plane3[r241+s] and not $0080; plane3[r241+s+1] := plane3[r241+s]; end; addscore (1); end; end; end; if (xkoordpacman = 8) and (ykoordpacman = 191) and (plane3[193] <> 0) then begin PowerPill := kraftmax-25*aggression; for i := 193 to 198 do plane3[i] := $0000; addscore (4); end else begin if (xkoordpacman = 30) and (ykoordpacman = 30) and (plane3[512] <> 0) then begin PowerPill := kraftmax-25*aggression;; for i := 32 to 37 do begin plane3[240+i] := plane3[240+i] and $00FF; plane3[480+i] := plane3[480+i] and $FF00; plane3[512] := 0; end; addscore (4); end else begin if xkoordpacman = 294 then begin if (ykoordpacman = 30) and (plane3[4352] <> 0) then begin PowerPill := kraftmax-25*aggression;; for i := 32 to 37 do plane3[4320+i] := $0000; addscore (4); end else begin if (ykoordpacman = 191) and (plane3[4513] <> 0) then begin PowerPill := kraftmax-25*aggression;; for i := 193 to 198 do plane3[4320+i] := $0000; addscore (4); end; end; end; end; end; if xkoordpacman = pacmanstartx then begin if (ykoordpacman < 114) and (ykoordpacman > 84) and fruitdisplay then begin addscore(100*fruitnr); fruitend := fruitlength end; end; if (fruitstart = bullets+20) and not closed then begin for i := 2 to 5 do if (xkoord[i] = 206) and (ykoord[i] > 76) and (ykoord[i] < 122) then begin if ykoord[i] < 99 then enemydir[i] := 1 else enemydir[i] := -1; end; layoutenemy[271] := layoutenemy[271]-1; for i := 272 to 274 do if layoutenemy[i] = -1 then begin for j := i to 274 do layoutenemy[j] := layoutenemy[j+1]; layoutenemy[275] := 0; end; layoutenemy[421] := layoutenemy[421]-1; for i := 422 to 424 do if layoutenemy[i] = 1 then begin for j := i to 424 do layoutenemy[j] := layoutenemy[j+1]; layoutenemy[425] := 0; end; closed := true; end; if (fruitstart = bullets) and (fruitend = 0) and not fruitdisplay then begin displayfruit (0); fruitdisplay := true; end; if fruitend = fruitlength then erasefruit; end; procedure putpacmeninplace (nr : integer); var oldx : integer; oldy : integer; oldk : integer; begin generatefigur (1, pacmenplacex, 208-18*nr); oldx := xkoordpacman; oldy := ykoordpacman; oldk := PowerPill; xkoordpacman := pacmenplacex; ykoordpacman := 208-18*nr; PowerPill := 0; movepacman (0); xkoordpacman := oldx; ykoordpacman := oldy; PowerPill := oldk; end; procedure addscore; begin score := score+scorevalue; while score >= 1000 do begin score := score-1000; scoreaddon := scoreaddon+1; if scoreaddon >= 100 then begin scorecarry := (scoreaddon div 100)+scorecarry; scoreaddon := scoreaddon mod 100; writescoredigit (0, 333, 1); end; if score < 1000 then begin writescore (scoreaddon, 333-(digitwidth shl 1)-digitwidth, 1); writescoredigit (0, 349, 1); writescoredigit (0, 357, 0); end; end; while scoreaddon >= nextpacman do begin nextpacman := nextpacman shl 1; putpacmeninplace (Lives); Lives := Lives+1; end; writescore (score, 333, 0); end; procedure erasefigur (xkoord, ykoord : integer); var r : integer; p : integer; begin r := xkoord shr 4; for p := ykoord to ykoord+9 do begin plane1[240*r+p] := $0000; plane1[240*(r+1)+p] := $0000; end; Color(switch3); WriteRectangle(xkoord,xkoord+6,ykoord,ykoord+9,plane3); end; procedure erasetunnel; begin erasefigur (162, 0); erasefigur (162, 198); end;