{$H2560} {$S8} program xmas252; uses pcmaudio, fastfire, tiles; const MAXX = FIREWIDTH; MAXY = FIREHEIGHT; (* type PixelData = array[0..31999] of integer; *) type Picture = record magic:integer; mode:integer; palette: array[0..15] of integer; pixels: PixelData; end; var firecells: FireBuf; firepalette: array [0..15] of integer = { ( $FFA, $FF8, $FF4, $FF0, $FE0, $FD0, $FA0, $F90, $F00, $E00, $D00, $A00, $800, $600, $300, $000); } { ( $FFA, $FFA, $FFA, $FFA, $FF0, $FF0, $FF0, $FF0, } ( $00F, $00F, $00F, $00F, $00F, $00F, $00F, $00F, $FF0, $FD0, $FA0, $C00, $A00, $700, $400, $000); x,y:integer; infile:file; pic:^Picture; tilesheet:^Picture; animationTick:integer; animationHold:integer; animationState:integer; filename: string; audiodata: SndBufPtr; procedure createPalette; var i:integer; begin for i := 15 downto 0 do setpalette(15 - i, firepalette[i]); end; procedure fireItUp; var x,y:integer; begin y := MAXY - 1; for x := 1 to MAXX - 1 do firecells[y, x] := random and 127; end; procedure updateFire; var i,x,y:integer; begin for y := 0 to MAXY - 2 do for x := 1 to MAXX - 1 do begin i := ((firecells[y + 1, x - 1] + firecells[y + 1, x] + firecells[y + 1, x + 1] + firecells[y + 2, x]) ) shr 2; if i > 0 then i := i - 1; firecells[y, x] := i; end; end; procedure drawFire(startX,startY:integer); var x, y, col, col2:integer; begin for y := 0 to MAXY - 1 do begin x := 0; for col in firecells[y] do begin { scale and clamp color value } col2 := col shr 3; if col2 > FIREMAXCOLOR then col2 := FIREMAXCOLOR; putpixel(startX + x, startY + y, col2); x := x + 1; end; end; end; procedure readBackgroundPic(filename:string); var i:integer; begin open(infile, filename, ModeReadonly); read(infile, pic^); close(infile); for i := 0 to 15 do SetPalette(i, pic^.palette[i]); PutScreen(pic^.pixels); end; procedure animate; var tileSrcX,tilesrcY:integer; begin animationTick := animationTick + 1; if animationHold = 0 then animationHold := 40; if animationTick < animationHold then exit; animationTick := 0; case animationState of 0: begin tileSrcX := 0; tileSrcY := 0; animationHold := 40; end; 1: begin tileSrcX := 19; tileSrcY := 0; animationHold := 20; if random and 7 > 4 then animationState := -1; end; 2: begin tileSrcX := 38; tileSrcY := 0; animationHold := 2; end; 3: begin; tileSrcX := 57; tileSrcY := 0; animationHold := 2; end; 4: begin tileSrcX := 0; tileSrcY := 13; animationHold := 15; end; 5: begin tileSrcX := 57; tileSrcY := 0; animationHold := 2; end; 6: begin tileSrcX := 38; tileSrcY := 0; animationHold := 2; end; 7: begin tileSrcX := 0; tileSrcY := 0; animationHold := 2; animationState := -1; end; end; CopyTilesScr(tilesheet^.pixels, tileSrcX, tileSrcY, 34,34, 19,13); animationState := animationState + 1; end; procedure readTilesheet; var filename:string; i:integer; begin filename := 'tilesheet.pict'; open(infile, filename, ModeReadonly); read(infile, tilesheet^); close(infile); end; function newAudioData(fname:string):SndBufPtr; var i,size:integer; c:char; buf:SndBufPtr; f:file; begin open(f, fname, ModeReadOnly); size := FileSize(f); new(buf, size); buf^ := ''; write('Reading ', size, ' bytes...'); for i := 1 to size do begin read(f,c); AppendChar(buf^,c); end; writeln; close(f); newAudioData := buf; end; begin if ParamCount > 0 then filename := ParamStr(1) else filename := 'xmas25bg.pict'; Randomize; audiodata := newAudioData('fireplace-loop.tdrau'); InitGraphics; new(pic); readBackgroundPic(filename); new(tilesheet); readTilesheet; SampleQStart(audiodata, true, 22050); while not ConAvail do begin fireItUp; FastFireUpdate(firecells); { updateFire; } FastFireDraw(firecells, 216, 165); { drawFire(216, 165); } animate; end; SampleQStop; for y := 0 to MAXY do begin x := firecells[y, 10]; drawline(0, y, x, y, 1); end; InitGraphics; dispose(tilesheet); dispose(pic); dispose(audiodata); end.