Tridora-CPU/examples/xmas25.pas

{$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.