Kurs Turbo Pascala

UNIT FONTS;

INTERFACE

USES Types, Errors, Standard;

TYPE
   PFont=^TFont;

   TWzor=ARRAY[1..255, 0..7] OF Byte;
   PWzor=^TWzor;

   TTabKon=ARRAY[1..255] OF Byte;
   PTabKon=^TTabKon;

   TTabAscii=ARRAY[0..255] OF Byte;
   PTabAscii=^TTabKon;

   TFontFile=RECORD
     FileType      :ARRAY [1..4] OF CHAR;
     MaxL          :Byte;
   END;

   TFont=RECORD
     MaxL          :Byte;
     Wzor          :PWzor;
     TabKon        :PTabKon;
     TabAscii      :PTabAscii;
   END;

VAR

   DefaultFont:PFont;



FUNCTION F_LoadFont(Font:PFont; CONST Fn:STRING):Byte;
FUNCTION F_SaveFont(Font:PFont; CONST Fn:STRING):Byte;
FUNCTION F_MakeAsciiTab(Font:PFont):Byte;

PROCEDURE F_NewFont(VAR Font:PFont);
PROCEDURE F_FreeFont(VAR Font:PFont);


IMPLEMENTATION

PROCEDURE F_NewFont(VAR Font:PFont);
BEGIN
 New(Font);

 Font^.MaxL:=0;
 Font^.Wzor  :=NIL;
 Font^.TabKon:=NIL;
 Font^.TabAscii:=NIL;
END;

PROCEDURE F_FreeFont(VAR Font:PFont);
BEGIN
 IF Font=NIL THEN Exit;
 IF Font^.Wzor  <>NIL THEN FreeMem(Font^.Wzor, Font^.MaxL SHL 3);
 IF Font^.TabKon<>NIL THEN FreeMem(Font^.TabKon, Font^.MaxL);
 IF Font^.TabAscii<>NIL THEN FreeMem(Font^.TabAscii, SizeOf(TTabAscii));
 Dispose(Font);
 Font:=NIL;
END;

FUNCTION F_MakeAsciiTab(Font:PFont):Byte;
VAR A:Byte;
BEGIN
 F_MakeAsciiTab:=E_OBIEKT;

 IF Font=NIL THEN Exit;
 IF Font^.TabAscii=NIL THEN GetMem(Font^.TabAscii, SizeOf(TTabAscii));

 S_FillChar32(Font^.TabAscii, SizeOf(TTabAscii), 0);

 FOR A:=1 TO Font^.MaxL DO
     Font^.TabAscii^[Font^.TabKon^[A]]:=A;

 F_MakeAsciiTab:=E_OK;

END;


FUNCTION F_LoadFont(Font:PFont; CONST Fn:STRING):Byte;
VAR F:File;
   Temp:TFontFile;

BEGIN
 F_LoadFont:=E_PLIK;

 IF Font=NIL THEN Exit;

 Assign(F, Fn);
 {$I-}
 Reset(F, 1);
 {$I+}

 F_LoadFont:=E_PLIK;
 IF IOResult<>0 THEN Exit;

 F_LoadFont:=E_ZLY_FORMAT;
 IF FileSize(F)
 BlockRead(F, Temp, SizeOf(TFontFile));
 Font^.MaxL:=Temp.MaxL;


 IF (Temp.FileType<>'Font') OR
    (Temp.MaxL SHL 3+Temp.MaxL+SizeOf(TFontFile)<>FileSize(F)) OR
    ((MaxAvail     AND NOT ((Font^.Wzor=NIL) OR (Font^.TabKon=NIL)))
    THEN
      BEGIN
        IF ((MaxAvail         AND NOT ((Font^.Wzor=NIL) OR (Font^.TabKon=NIL)))
            THEN F_LoadFont:=E_PAMIEC
            ELSE F_LoadFont:=E_ZLY_FORMAT;

        Close(F);
        Exit;
      END;

 IF (Font^.Wzor=NIL) OR (Font^.TabKon=NIL)
 THEN
   BEGIN
     GetMem(Font^.Wzor, Temp.MaxL SHL 3);
     GetMem(Font^.TabKon, Temp.MaxL);
   END;


 BlockRead(F, Font^.Wzor^,   Temp.MaxL SHL 3);
 BlockRead(F, Font^.TabKon^, Temp.MaxL);

 F_MakeAsciiTab(Font);

 Close(F);
 F_LoadFont:=E_OK;
 DefaultFont:=Font;
END;

FUNCTION F_SaveFont(Font:PFont; CONST Fn:STRING):Byte;
VAR F:File;
   Temp:TFontFile;

BEGIN

 IF Font=NIL THEN Exit;

 Assign(F, Fn);
 {$I-}
 Rewrite(F, 1);
 {$I+}
 IF IOResult<>0 THEN Exit;

 Temp.FileType:='Font';
 Temp.MaxL:=Font^.MaxL;

 BlockWrite(F, Temp, SizeOf(TFontFile));

 BlockWrite(F, Font^.Wzor^,   Temp.MaxL SHL 3);
 BlockWrite(F, Font^.TabKon^, Temp.MaxL);


 Close(F);
 F_SaveFont:=E_OK;

END;


END.

UNIT TYPES;

INTERFACE

TYPE
   PString   = ^STRING;
   PChar     = ^Char;
   String10  = STRING[10];

   PRect     = ^TRect;
   TRect     = RECORD
     X, Y,
     W, H    : Integer;
   END;


   PSprite   = ^TSprite;
   TSprite   = RECORD

     X, Y    : Integer;
     DX, DY  : Integer;
     Klatka  : Byte;

   END;


IMPLEMENTATION
END.

UNIT Errors;



INTERFACE



CONST MaxError=12;


     E_Error:ARRAY[0..MaxError] OF STRING[40]=
     ('Wszystko OK',
      'Brak pamieci rzeczywistej',
      'Brak pliku ',
      'Nie zainstalowano sterownika myszki',
      'Nieprawidlowy format pliku',
      'Zly katalog',
      'Brak sterownika pamieci EMS',
      'Brakuje pamieci EMS',
      'Brak miejsca na dysku',
      'Bitmapa ma nieprawidlowa ilosc kolorow',
      'Bitmapa ma zla rozdzielczosc',
      'Brak podanego obiektu',
      'Zly format pliku');

      E_OK=0;
      E_PAMIEC=1;
      E_PLIK=2;
      E_MYSZ=3;
      E_FORMAT=4;
      E_KATALOG=5;
      E_EMS=6;
      E_PAMIECEMS=7;
      E_DYSK=8;
      E_BPP=9;
      E_SIZE=10;
      E_OBIEKT=11;
      E_ZLY_FORMAT=12;

      D_CAPTION='UWAGA NAPOTKANO BLEDY !';



TYPE   PError          =^TError;



      TError          = RECORD
        Next          : PError;
        Caption       : STRING[80];
      END;



VAR
      {PIERWSZY BLAD NA LISCIE}
      FirstError      : PError;

      {AKTUALNY STWORZONY BLAD}
      ActualError     : PError;




PROCEDURE AddError(CONST S:STRING);
PROCEDURE ShowErrors;
PROCEDURE FreeErrors;



IMPLEMENTATION



PROCEDURE AddError(CONST S:STRING);
BEGIN

 {JESLI JEST JUZ JAKIS BLAD}
 IF Assigned(ActualError) THEN

    BEGIN
      {TWORZY NOWY ELEMENT}
      New(ActualError^.Next);

      {PRZECHODZI DO NIEGO}
      ActualError:=ActualError^.Next;
    END
    ELSE
    BEGIN
      {JESLI NIE MA JESZCZE ZADNEGO TO GO TWORZY}
      New(ActualError);

      {PODSTAWIA DO PIERWSZEGO ELEMENTU NOWO STWORZONY}
      FirstError:=ActualError;
    END;

 {DODAJE KOMUNIKAT}
 Move(S, ActualError^.Caption, SizeOf(ActualError^.Caption));

 {NIE MA NA RAZIE KOLEJNEGO ELEMENTU}
 ActualError^.Next:=NIL;
END;




PROCEDURE ShowErrors;

VAR
   {W RAZIE BLEDU BEDZIE ZAWIERALO WARTOSC PORTU KLAWIATURY}
   PortValue  : Word;

BEGIN

 {JEZELI WSZYSTKO JEST BEZBLEDNIE WYCHODZI}
 IF NOT Assigned(FirstError) THEN Exit;

 {USTAWIENIE TRYBU TEKSTOWEGO}
 ASM
   Mov  Ax, 3h
   Int  10h
 END;

 {KOMUNIKAT POCZATKOWY}
 WriteLn(D_CAPTION);
 WriteLn;

 {BEDZIE PRZEGLADAL LISTE BLEDOW OD POCZATKU}
 ActualError:=FirstError;

 {DOPLOKI ISTNIEJE W PAMIECI ZAPIS BLEDU}
 WHILE Assigned(ActualError) DO
   BEGIN
     {WYPISZ KOMUNIKAT BLEDU}
     WriteLn('    '+ActualError^.Caption);

     {PRZEJDZ DO NASTEPNEGO BLEDU}
     ActualError:=ActualError^.Next;
   END;

 {INFORMACJA O WOLNEJ PAMIECI}
 WriteLn;
 WriteLn('WOLNA PAMIEC :', MemAvail);

 {PYTANIE O KONTUNUACJE}
 WriteLn;
 WriteLn('CZY CHCESZ KONTYNUOWAC? PROGRAM MOZE NIE DZIALAC POPRAWNIE (T/N)');

 {DOPLOKI NIE PUSCISZ KLAWISZA T LUB N}
 WHILE NOT (PortValue IN [{T}20+128, {N}49+128]) DO

 {POBIERA WARTOSC PORTU KLAWIATURY}
   PortValue:=PORT[$60];

 {JESLI NIE chcESZ KONTYNUOWAC}
 IF PortValue=49+128 THEN
 BEGIN
   {ZWOLNIJ PAMIEC}
   FreeErrors;

   {WYLACZ PROGRAM}
   Halt;
 END;



END;




PROCEDURE FreeErrors;
BEGIN

 {DOPLOKI ISTNIEJE W PAMIECI ZAPIS BLEDU}
 WHILE Assigned(FirstError) DO
   BEGIN
     {PODSTAW DO CHWILOWEJ PAMIECI ADRES PIERWSZEGO BLEDU}
     ActualError:=FirstError;

     {PRZEJDZ DO NASTEPNEGO BLEDU}
     FirstError:=ActualError^.Next;

     {ZWOLNIJ PAMIEC}
     Dispose(ActualError);
   END;

 {NIE MA JUZ NIC W PAMIECI}
 ActualError:=NIL;
END;

END.