Program vytvorí prechod medzi dvoma farbami

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Category: KMP (Club of young programmers)

Author: Aleš Kucik
web: www.webpark.cz/prog-pascal

Program: Makepal.pas,  Graphx.pas,  Textscr.pas
File exe: Makepal.exe

MAKEPAL - návod
  • tento program slouží k vytvoření různých VGA palet. Zajímavou možností je vytvoření plynulého přechodu mezi dvěma barvami.
  • program je nutné spouštět z příkazového řádku (jako parametr je vyžadován název souboru, kam bude paleta uložena) Např.: makepal.exe paleta1
  • pokud tento soubor již existuje bude přepsán!!!
  • vzniklý soubor je typový soubor. Typu array [0..255,0..2] of byte.
OVLÁDÁNÍ -
Mezi paložkami se pohybujete stiskem klávesy se znakem počátečního písmene zvolené položky (pro položku 1BARVA to je "1" atd.)
šipka nahoru - zvětšuje hodnotu položky
šipka dolů - zmenšuje hodnotu položky
položky:
  • 1BARVA - výběr 1. barvy (klávesa "1")
  • 2BARVA - vžběr 2. barvy (klávesa "2")
  • R - hodnota červené složky dané barvy (klávesa "R")
  • G - hodnota zelené složky dané barvy (klávesa "G")
  • B - hodnota modré složky dané barvy (klávesa "B")
  • "DANÁ BARVA" je ta, která byla vybrána naposled (pokud jste naposled stiskli "1" budete měnit složky 1. barvy)
  • TEXT - možnost nastavení barvy textu (může se stát, že na text na obrazovce vyjde černá barva a text se tak stane nečitelný - touto položkou lze barvu měnit)
  • "P...Process" - vytvoří plynulý přechod mezi 1. a 2. barvou
  • program se ukončí stiskem klávesy "ESC"
{ TEXTSCR.PAS                              Copyright (c) Ales Kucik }
{ Unit pre pracu s obrazovkou v textovom mode.                      }
{                                                                   }
{ Datum:29.11.2002                             http://www.trsek.com }
 
unit TextScr;
interface
uses Crt;
const
  page0= $0000;
  page1= $1000;
  page2= $2000;
  page3= $3000;
 
  page_size=$FA0;
 
 
var
  ActivePage:byte;
  VideoSeg:word;
 
procedure SetCursor(h,d:byte); {Cisla v intervalu 0..7}
procedure CursorOn;
procedure CursorOff;
procedure GetChar(var character:char; var attr:byte);
procedure SetActivePage(number:byte);
procedure WriteXY(x,y:byte; s:string);
procedure HWriteXY(x,y,z,c:byte; s:string);
procedure NormalWin(x1,y1,x2,y2:byte);
procedure ErrorMes(s:string);
 
{Prvni vraci znak a potom atribut}
 
function GetKey:word;
function GetTextMode:byte; {Vraci cislo textoveho modu}
function GetActivePage:byte;
 
 
implementation
 
 
procedure SetCursor; assembler;
asm
        mov        ah, 01b
        mov        cl, d
        mov        ch, h
        int        10h
end;
 
procedure CursorOn; assembler;
asm
        mov        ah, 01h
        mov        cl, 07h
        mov        ch, 06h
        int        10h
end;
 
procedure CursorOff; assembler;
asm
        mov        ah, 01h
        mov        cl, 20h
        mov        ch, 20h
        int        10h
end;
 
procedure GetChar(var character:char; var attr:Byte);
var l,h:byte;
begin
  asm
        mov     bh, 0h
        mov     ah, 8h
        int     $10
        mov     l, al
        mov     h, ah
  end;
  character:=chr(l);
  attr:=h;
end;
 
function GetTextMode;
var b:byte absolute 0:$0449;
begin
  GetTextMode:=b;
end;
 
procedure SetActivePage;
begin
  asm
        mov     ah, 05h
        mov     al, number
        int     10h
  end;
  ActivePage:=number;
end;
 
 
function GetActivePage:byte;
begin
   GetActivePage:=ActivePage;
end;
 
function GetKey:word;
var a:word;
begin
  a:=ord(readkey);
  if a=0 then a:=256+ord(readkey);
  getKey:=a;
end;
 
procedure WriteXY;
begin
  gotoxy(x,y);
  write(s);
end;
 
procedure HWriteXY;
var attr:byte;
begin
  gotoxy(x,y);
  attr:=textattr;
  write(s);
  textcolor(c);
  gotoxy(x+z-1,y);
  write(s[z]);
  textattr:=attr;
end;
 
procedure NormalWin;
var
  i,j:byte;
 
begin
  window(x1,y1,x2,y2);
  clrscr;
  gotoxy(2,1);
  write(#201);
  for i:=1 to x2-x1-3 do write(#205);
  write(#187);
  for i:=2 to y2-y1 do
    begin
      gotoxy(2,i);
      write(#186);
      gotoxy(x2-x1,i);
      write(#186);
    end;
  gotoxy(2,y2-y1+1);
  write(#200);
  for i:=1 to x2-x1-3 do write(#205);
  write(#188);
  window(1,1,80,25);
end;
 
procedure ErrorMes;
var
  x,l:byte;
  attr:byte;
begin
  attr:=TextAttr;
  textcolor(yellow);
  textbackground(red);
  l:=length(s);
  if l<28 then l:=28;
  x:=(80-l)div 2 -2;
  NormalWin(x,11,x+l+4,14);
  writeXY(x+2,12,s);
  l:=(l-28)div 2;
  writeXY(x+l+2,13,'Neco stiskni/Press something');
  TextAttr:=attr;
end;
 
begin
   ActivePage:=0;
   if GetTextMode=7 then VideoSeg:=$B000
   else VideoSeg:=$B800;
end.