Информационный сервер для программистов: Исходники со всего света. Паскальные исходники со всего света
  Powered by Поисковый сервер Яndex: Найдется ВСЁ!
На Главную Pascal Форум Информер Страны мира
   Demo Making    >>    snowy
   
 
 Trivial Snow   Алексей Ванеев 26.06.1996

Тривиальная программка, реализующая упрощенный эффект падающего снега



1k 
 

{> Cut here. FileName= SNOWY.PAS } {$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-} {$M 4096,0,655360} { tapstep = 4 } PROGRAM Snowy; CONST FlakeCount = 1024; TYPE TFlake = RECORD x,y: INTEGER; Depth: BYTE; Falling: BOOLEAN; InAir: BOOLEAN; END; VAR Screen: ARRAY[0..63999] OF BYTE ABSOLUTE $A000:0; Flake: ARRAY[1..FlakeCount] OF TFlake; FUNCTION Keypressed: BOOLEAN; ASSEMBLER; ASM XOR BX,BX MOV AH,01H INT 16H JZ @Done MOV BX,-1 @Done: MOV AX,BX END; FUNCTION Readkey: WORD; ASSEMBLER; ASM XOR AH,AH INT 16H END; PROCEDURE VideoModeSet(Mode: BYTE); ASSEMBLER; ASM XOR AH,AH MOV AL,[Mode] INT 10H END; PROCEDURE PaletteSet(VAR PaletteBuffer; StartColour, EndColour: BYTE); ASSEMBLER; ASM PUSH DS LDS SI,[PaletteBuffer] XOR CX,CX MOV CL,[EndColour] MOV AH,[StartColour] MOV BH,AH CLD MOV BL,1 CMP CL,AH JA @@Incrementing STD NEG BL XCHG CL,AH @@Incrementing: SUB CL,AH INC CX CLI @@FillLoop: MOV DX,3C8H MOV AL,BH OUT DX,AL MOV DX,3C9H LODSB OUT DX,AL LODSB OUT DX,AL LODSB OUT DX,AL ADD BH,BL LOOP @@FillLoop STI @@Done: POP DS END; PROCEDURE TimerWait; VAR i: WORD; BEGIN i:=MEM[$40:$6C]; WHILE i=MEM[$40:$6C] DO ; END; PROCEDURE PixelPut(x,y: INTEGER; c: BYTE); BEGIN IF (x>-1) AND (x<320) AND (y>-1) AND (y<200) THEN Screen[y*320+x]:=c; END; PROCEDURE GeneratePalette; TYPE TComponent = RECORD r,g,b: BYTE; END; VAR NewPalette: ARRAY[0..255] OF TComponent; i: INTEGER; BEGIN FOR i:=0 TO 255 DO BEGIN NewPalette[i].r:=i DIV 4; NewPalette[i].g:=i DIV 4; NewPalette[i].b:=i DIV 4; END; PaletteSet(NewPalette,1,255); END; PROCEDURE InitializeSnow; VAR i: INTEGER; BEGIN FOR i:=1 TO FlakeCount DO BEGIN Flake[i].Falling:=FALSE; Flake[i].InAir:=FALSE; END; END; PROCEDURE ShowSnow; VAR i: INTEGER; BEGIN FOR i:=1 TO FlakeCount DO IF Flake[i].InAir THEN PixelPut(Flake[i].x,Flake[i].y,Flake[i].Depth*8); END; PROCEDURE MoveSnow; VAR i: INTEGER; NewSnow: BYTE; Spd,Loc: INTEGER; BEGIN NewSnow:=RANDOM(255); FOR i:=1 TO FlakeCount DO BEGIN IF (NOT Flake[i].Falling) AND (NewSnow>0) THEN BEGIN Flake[i].y:=RANDOM(60)-70; Flake[i].x:=RANDOM(320); Flake[i].Falling:=TRUE; Flake[i].InAir:=TRUE; Flake[i].Depth:=RANDOM(32); END ELSE BEGIN Spd:=Flake[i].Depth DIV 12+1+RANDOM(2); Flake[i].y:=Flake[i].y+Spd; Flake[i].x:=Flake[i].x-2+RANDOM(5); IF Flake[i].y>199 THEN BEGIN Flake[i].InAir:=FALSE; Flake[i].Falling:=FALSE; END; END; IF NewSnow>0 THEN NewSnow:=NewSnow-1; END; END; PROCEDURE KillSnow; VAR i: INTEGER; BEGIN FOR i:=1 TO FlakeCount DO IF (Flake[i].Falling) AND (Flake[i].InAir) THEN PixelPut(Flake[i].x,Flake[i].y,0); END; BEGIN VideoModeSet($13); { set 320x200x256 videomode } InitializeSnow; { initialize snowflakes } GeneratePalette; { set suitable palette } REPEAT MoveSnow; { change positions of snowflakes } ShowSnow; { show snowflakes } TimerWait; { pause for about 1/18th seconds } KillSnow; { remove snowflakes } UNTIL Keypressed; { repeat, until the key was pressed } Readkey; { flush keyboard buffer } VideoModeSet($3); { set 80x25 textmode } END.