Hiển thị kết quả từ 1 đến 10 / 10
  1. #1
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts

    Hấp dẫn đây ! Một số thư viện hay cho TurboPascal

    Để cho việc học lập trình thêm phần hứng thú, tôi tổng hợp một số thư viện dùng cho Turbo Pascal, các bạn có thể sửa chữa, bổ sung theo ý mình cho mục đích học tập.

    1. MÃ CRC:
    Thư viện CRC32:

    Code:
    {Thông tin: https://vi.wikipedia.org/wiki/CRC}
    (*From ricc!L-relcom%ricc.alma-ata.su Mon Feb 15 20:36:38 ATA 1993
    To: valera@aebexc.alma-ata.su
    From: ***@ecoc.tashkent.su (Dmitry E. Kalintsew, aka Dee)
    Subject: [NEWS] Šâ® ¯à®á¨« CRC? ‹®¢¨â¥!
    Date: Wed, 10 Feb 93 11:12:42 +0500
    Organization: =ECOLOGICAL UNION=
    
    -- 
    	Dmitry E. Kalintsew, AKA Dee. UUCP regional center newsmaster.
    		Freelance hacker, personal tm: *** SoftWorks :-)
         E-mail: ***@ecoc.tashkent.su, ***@ecoc.wa.com, 2:5085/5@Fidonet.org
    		     Phone: +7(371)245-7681 after 01:00 GMT
    *)
    
    UNIT CRC32;
    INTERFACE
    
    TYPE String8 = String[8];
    CONST
       ZBUFSIZE = 63000;
    TYPE
       buftype = ARRAY[0..ZBUFSIZE] OF BYTE; 
    VAR
      fbuf  : buftype;
      
    FUNCTION UpdCrc(cp: BYTE; crc: WORD): WORD;
    FUNCTION UpdC32(octet: BYTE; crc: LONGINT) : LONGINT;
    FUNCTION Z_FileCRC32 (VAR f: FILE): LONGINT;
    function CRC32HEX (A: LongInt): String8;
    function CRC32FILE (Var f: FILE): String8;
    
    IMPLEMENTATION
    
    
    CONST crctab: ARRAY[0..255] OF WORD = (
        $0000,  $1021,  $2042,  $3063,  $4084,  $50a5,  $60c6,  $70e7,
        $8108,  $9129,  $a14a,  $b16b,  $c18c,  $d1ad,  $e1ce,  $f1ef,
        $1231,  $0210,  $3273,  $2252,  $52b5,  $4294,  $72f7,  $62d6,
        $9339,  $8318,  $b37b,  $a35a,  $d3bd,  $c39c,  $f3ff,  $e3de,
        $2462,  $3443,  $0420,  $1401,  $64e6,  $74c7,  $44a4,  $5485,
        $a56a,  $b54b,  $8528,  $9509,  $e5ee,  $f5cf,  $c5ac,  $d58d,
        $3653,  $2672,  $1611,  $0630,  $76d7,  $66f6,  $5695,  $46b4,
        $b75b,  $a77a,  $9719,  $8738,  $f7df,  $e7fe,  $d79d,  $c7bc,
        $48c4,  $58e5,  $6886,  $78a7,  $0840,  $1861,  $2802,  $3823,
        $c9cc,  $d9ed,  $e98e,  $f9af,  $8948,  $9969,  $a90a,  $b92b,
        $5af5,  $4ad4,  $7ab7,  $6a96,  $1a71,  $0a50,  $3a33,  $2a12,
        $dbfd,  $cbdc,  $fbbf,  $eb9e,  $9b79,  $8b58,  $bb3b,  $ab1a,
        $6ca6,  $7c87,  $4ce4,  $5cc5,  $2c22,  $3c03,  $0c60,  $1c41,
        $edae,  $fd8f,  $cdec,  $ddcd,  $ad2a,  $bd0b,  $8d68,  $9d49,
        $7e97,  $6eb6,  $5ed5,  $4ef4,  $3e13,  $2e32,  $1e51,  $0e70,
        $ff9f,  $efbe,  $dfdd,  $cffc,  $bf1b,  $af3a,  $9f59,  $8f78,
        $9188,  $81a9,  $b1ca,  $a1eb,  $d10c,  $c12d,  $f14e,  $e16f,
        $1080,  $00a1,  $30c2,  $20e3,  $5004,  $4025,  $7046,  $6067,
        $83b9,  $9398,  $a3fb,  $b3da,  $c33d,  $d31c,  $e37f,  $f35e,
        $02b1,  $1290,  $22f3,  $32d2,  $4235,  $5214,  $6277,  $7256,
        $b5ea,  $a5cb,  $95a8,  $8589,  $f56e,  $e54f,  $d52c,  $c50d,
        $34e2,  $24c3,  $14a0,  $0481,  $7466,  $6447,  $5424,  $4405,
        $a7db,  $b7fa,  $8799,  $97b8,  $e75f,  $f77e,  $c71d,  $d73c,
        $26d3,  $36f2,  $0691,  $16b0,  $6657,  $7676,  $4615,  $5634,
        $d94c,  $c96d,  $f90e,  $e92f,  $99c8,  $89e9,  $b98a,  $a9ab,
        $5844,  $4865,  $7806,  $6827,  $18c0,  $08e1,  $3882,  $28a3,
        $cb7d,  $db5c,  $eb3f,  $fb1e,  $8bf9,  $9bd8,  $abbb,  $bb9a,
        $4a75,  $5a54,  $6a37,  $7a16,  $0af1,  $1ad0,  $2ab3,  $3a92,
        $fd2e,  $ed0f,  $dd6c,  $cd4d,  $bdaa,  $ad8b,  $9de8,  $8dc9,
        $7c26,  $6c07,  $5c64,  $4c45,  $3ca2,  $2c83,  $1ce0,  $0cc1,
        $ef1f,  $ff3e,  $cf5d,  $df7c,  $af9b,  $bfba,  $8fd9,  $9ff8,
        $6e17,  $7e36,  $4e55,  $5e74,  $2e93,  $3eb2,  $0ed1,  $1ef0
    );
    
    
    FUNCTION UpdCrc(cp: BYTE; crc: WORD): WORD;
    BEGIN { UpdCrc }
       UpdCrc := crctab[((crc SHR 8) AND 255)] XOR (crc SHL 8) XOR cp
    END;
    
    CONST crc_32_tab: ARRAY[0..255] OF LONGINT = (
    $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3,
    $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91,
    $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
    $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5,
    $3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,
    $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
    $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
    $2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d,
    $76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
    $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,
    $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457,
    $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
    $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb,
    $4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,
    $5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
    $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad,
    $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683,
    $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
    $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7,
    $fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
    $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
    $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79,
    $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f,
    $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
    $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
    $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21,
    $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
    $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
    $a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db,
    $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
    $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf,
    $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
    );
    
    FUNCTION UpdC32(octet: BYTE; crc: LONGINT) : LONGINT;
    BEGIN { UpdC32 }
       UpdC32 := crc_32_tab[BYTE(crc XOR LONGINT(octet))] XOR ((crc SHR 8) AND $00FFFFFF)
    END;
    
    {MOD}
    FUNCTION Z_FileCRC32 (VAR f: FILE): LONGINT;
    VAR
       crc   : LONGINT;
       n,
       bread : Word;
    BEGIN
       crc := $FFFFFFFF;
       Seek(f,0);
       IF (IOresult <> 0) THEN
          {null};
       REPEAT
          BlockRead(f,fbuf,ZBUFSIZE,bread);
          FOR n := 0 TO (bread - 1) DO crc := UpdC32 (fbuf [n],crc)
       UNTIL (bread < ZBUFSIZE) OR (IOresult <> 0);
       Seek(f,0);
       IF (IOresult <> 0) THEN
          {null};
       crc := crc xor $FFFFFFFF;
       Z_FileCRC32 := crc
    END;
    
    {OLD NAME = function HexL(A: LongInt): String8;}
    function CRC32HEX (A: LongInt): String8;
    type
      B4 = array [1..4] Of Byte;
    
    var
      L: LongInt;
      B: B4 absolute L;
      S: String8;
      B1: Byte;
      i: Byte;
    
    begin
      L := A;
      S := '';
      for i := 4 downto 1 do
      begin
        B1 := B[i];
        B1 := B1 shr 4;
        if B1 < 10 then
          S := S + Char($30+Byte(B1))
        else
          S := S + Char(65+Byte(B1 - 10));
        B1 := B[i];
        B1 := B1 and Byte($0F);
        if B1 < 10 then
          S := S + Char($30+Byte(B1))
        else
          S := S + Char(65+Byte(B1 - 10));
      end;
      CRC32HEX := S;
    end;
    function CRC32FILE (Var f :FILE): String8;
    begin
    CRC32FILE := CRC32HEX (Z_FileCRC32(f));
    end;
    END. {unit}
    Chương trình Demo lấy mã CRC32 từ dòng lệnh:
    - Đặt tên file là DemoCRC.Pas =>DemoCRC.exe
    - Tại DOS: DemoCRC <TÊN FILE>


    Code:
    {$M 2048,0,655360}
    USES
      CRC32;
    VAR
      InF: File;
    
    procedure Help; {Cú pháp}
    begin
      WriteLn ('USAGE: DemoCRC <FILE>');
      Halt (0);
    end;
    
    BEGIN
      if ParamCount <> 1 then Help; {Lấy tham số dòng lệnh}
      FileMode := 0;
      Assign (InF, ParamStr (1));   {Mở file}
      {$I+} Reset (InF, 1); {$I-}
      if IOResult <> 0 then         {Có lỗi?}
      begin
        WriteLn ('Can''t open file: ', ParamStr (1)); {Thông báo lỗi}
        Halt (0);
      end;
      WriteLn ('CRC32 is: ', CRC32FILE (InF) ); {Mọi sự tốt lành: in ra mã CRC của file}
    END.
    **

    Chương trình đã biên dịch:
    http://www.mediafire.com/download/0b...kj/DemoCRC.zip
    Được sửa bởi ada95 lúc 13:29 ngày 04-08-2016 Reason: Bổ sung nguồn code
    Quote Quote

  2. Thành viên Like bài viết này:


  3. #2
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts

    2. Check mã MD5

    Thư viện MD5:
    {http://madeinbrazil.umforum.net/t274...-pascal-delphi }
    Code:
    UNIT MD5;
    
    INTERFACE
    CONST
        MD5Version :string = '102_2012/07/15_Sunday';
        CopyRight  :String = ' MD5 Message-Digest (c) 97-98 F . Piette V1_02 ';
    
    {$Q-}
    {$R-}
    TYPE
        string2= string[2];
        TMD5Context = record
            State :array[0..3] of LongInt;
            Count :array[0..1] of LongInt;
            case Integer of
            0: (BufChar :array[0..63] of Byte);
            1: (BufLong :array[0..15] of LongInt);
        end;
        TMD5Digest = array[0..15] of Char;
    
    procedure MD5Init (var MD5Context :TMD5Context);
    procedure MD5Update (var MD5Context :TMD5Context;
                        const Data;
                        Len :Integer);
    procedure MD5Transform (var Buf :array of LongInt;
                          const Data :array of LongInt);
    procedure MD5UpdateBuffer (var MD5Context :TMD5Context;
                              Buffer :Pointer;
                              BufSize :Integer);
    procedure MD5Final (var Digest :TMD5Digest; var MD5Context: TMD5Context);
    
    function GetMD5 (Buffer :Pointer; BufSize :Integer) :string;
    function MD5Str (Buffer :String) :string;
    function MD5File (sF :string) :string;  { }
    
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    IMPLEMENTATION
    const
        MaxBufSize = 16384;
    type
        PMD5Buffer = ^TMD5Buffer;
        TMD5Buffer = array [0..(MaxBufSize - 1)] of Char;
    
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    { MD5 initialization.  Begins an MD5 operation, writing a new context.        }
    procedure MD5Init (var MD5Context :TMD5Context);
    begin
        FillChar (MD5Context, SizeOf(TMD5Context), #0);
        with MD5Context do begin
            { Load magic initialization constants. }
            State[0] := LongInt($67452301);
            State[1] := LongInt($EFCDAB89);
            State[2] := LongInt($98BADCFE);
            State[3] := LongInt($10325476);
        end
    end;
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    { MD5 block update operation. Continues an MD5 message-digest operation,      }
    { processing another message block, and updating the context.                }
    procedure MD5Update (
        var MD5Context :TMD5Context;            { Context                        }
        const Data;                            { Input block                    }
        Len :Integer);                          { Length of input block          }
    type
        TByteArray = array [0..0] of Byte;
    var
        Index   :Word;
        T       :LongInt;
    begin
        with MD5Context do begin
            T := Count[0];
            Inc (Count[0], LongInt(Len) shl 3);
            if Count[0] < T then
                Inc (Count [1]);
            Inc (Count[1], Len shr 29);
            T := (T shr 3) and $3F;
            Index := 0;
            if T <> 0 then begin
                Index := T;
                T := 64 - T;
                if Len < T then begin
                    Move (Data, BufChar[Index], Len);
                    Exit;
                end;
                Move (Data, BufChar[Index], T);
                MD5Transform (State, BufLong);
                Dec (Len, T);
                Index := T;  { Wolfgang Klein, 05/06/99 }
            end;
            while Len >= 64 do begin
                Move (TByteArray(Data)[Index], BufChar, 64);
                MD5Transform (State, BufLong);
                Inc (Index, 64);
                Dec (Len, 64);
            end;
            Move (TByteArray(Data)[Index], BufChar, Len);
        end
    end;
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    { MD5 finalization. Ends an MD5 message-digest operation, writing the message }
    { digest and zeroizing the context.                                          }
    procedure MD5Final (var Digest :TMD5Digest; var MD5Context :TMD5Context);
    var
        Cnt :Word;
        P   :Byte;
    begin
        with MD5Context do begin
            Cnt := (Count[0] shr 3) and $3F;
            P := Cnt;
            BufChar [P] := $80;
            Inc (P);
            Cnt := 64 - 1 - Cnt;
            if Cnt < 8 then begin
                FillChar (BufChar[P], Cnt, #0);
                MD5Transform (State, BufLong);
                FillChar (BufChar, 56, #0);
                end
            else
                FillChar(BufChar[P], Cnt - 8, #0);
            BufLong[14] := Count[0];
            BufLong[15] := Count[1];
            MD5Transform(State, BufLong);
            Move(State, Digest, 16)
        end;
        FillChar(MD5Context, SizeOf(TMD5Context), #0)
    end;
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    { MD5 basic transformation. Transforms state based on block.                  }
    procedure MD5Transform (
        var Buf :array of LongInt;
        const Data :array of LongInt);
    var
        A, B, C, D :LongInt;
    
        procedure Round1 (var W :LongInt; X, Y, Z, Data :LongInt; S :Byte);
        begin
            Inc (W, (Z xor (X and (Y xor Z))) + Data);
            W := (W shl S) or (W shr (32 - S));
            Inc (W, X)
        end;
    
        procedure Round2 (var W :LongInt; X, Y, Z, Data :LongInt; S: Byte);
        begin
            Inc (W, (Y xor (Z and (X xor Y))) + Data);
            W := (W shl S) or (W shr (32 - S));
            Inc (W, X)
        end;
    
        procedure Round3 (var W :LongInt; X, Y, Z, Data :LongInt; S: Byte);
        begin
            Inc (W, (X xor Y xor Z) + Data);
            W := (W shl S) or (W shr (32 - S));
            Inc (W, X)
        end;
    
        procedure Round4 (var W :LongInt; X, Y, Z, Data :LongInt; S: Byte);
        begin
            Inc (W, (Y xor (X or not Z)) + Data);
            W := (W shl S) or (W shr (32 - S));
            Inc (W, X)
        end;
    begin
        A := Buf[0];
        B := Buf[1];
        C := Buf[2];
        D := Buf[3];
    
        Round1(A, B, C, D, Data[ 0] + LongInt($d76aa478),  7);
        Round1(D, A, B, C, Data[ 1] + LongInt($e8c7b756), 12);
        Round1(C, D, A, B, Data[ 2] + LongInt($242070db), 17);
        Round1(B, C, D, A, Data[ 3] + LongInt($c1bdceee), 22);
        Round1(A, B, C, D, Data[ 4] + LongInt($f57c0faf),  7);
        Round1(D, A, B, C, Data[ 5] + LongInt($4787c62a), 12);
        Round1(C, D, A, B, Data[ 6] + LongInt($a8304613), 17);
        Round1(B, C, D, A, Data[ 7] + LongInt($fd469501), 22);
        Round1(A, B, C, D, Data[ 8] + LongInt($698098d8),  7);
        Round1(D, A, B, C, Data[ 9] + LongInt($8b44f7af), 12);
        Round1(C, D, A, B, Data[10] + LongInt($ffff5bb1), 17);
        Round1(B, C, D, A, Data[11] + LongInt($895cd7be), 22);
        Round1(A, B, C, D, Data[12] + LongInt($6b901122),  7);
        Round1(D, A, B, C, Data[13] + LongInt($fd987193), 12);
        Round1(C, D, A, B, Data[14] + LongInt($a679438e), 17);
        Round1(B, C, D, A, Data[15] + LongInt($49b40821), 22);
    
        Round2(A, B, C, D, Data[ 1] + LongInt($f61e2562),  5);
        Round2(D, A, B, C, Data[ 6] + LongInt($c040b340),  9);
        Round2(C, D, A, B, Data[11] + LongInt($265e5a51), 14);
        Round2(B, C, D, A, Data[ 0] + LongInt($e9b6c7aa), 20);
        Round2(A, B, C, D, Data[ 5] + LongInt($d62f105d),  5);
        Round2(D, A, B, C, Data[10] + LongInt($02441453),  9);
        Round2(C, D, A, B, Data[15] + LongInt($d8a1e681), 14);
        Round2(B, C, D, A, Data[ 4] + LongInt($e7d3fbc8), 20);
        Round2(A, B, C, D, Data[ 9] + LongInt($21e1cde6),  5);
        Round2(D, A, B, C, Data[14] + LongInt($c33707d6),  9);
        Round2(C, D, A, B, Data[ 3] + LongInt($f4d50d87), 14);
        Round2(B, C, D, A, Data[ 8] + LongInt($455a14ed), 20);
        Round2(A, B, C, D, Data[13] + LongInt($a9e3e905),  5);
        Round2(D, A, B, C, Data[ 2] + LongInt($fcefa3f8),  9);
        Round2(C, D, A, B, Data[ 7] + LongInt($676f02d9), 14);
        Round2(B, C, D, A, Data[12] + LongInt($8d2a4c8a), 20);
    
        Round3(A, B, C, D, Data[ 5] + LongInt($fffa3942),  4);
        Round3(D, A, B, C, Data[ 8] + LongInt($8771f681), 11);
        Round3(C, D, A, B, Data[11] + LongInt($6d9d6122), 16);
        Round3(B, C, D, A, Data[14] + LongInt($fde5380c), 23);
        Round3(A, B, C, D, Data[ 1] + LongInt($a4beea44),  4);
        Round3(D, A, B, C, Data[ 4] + LongInt($4bdecfa9), 11);
        Round3(C, D, A, B, Data[ 7] + LongInt($f6bb4b60), 16);
        Round3(B, C, D, A, Data[10] + LongInt($bebfbc70), 23);
        Round3(A, B, C, D, Data[13] + LongInt($289b7ec6),  4);
        Round3(D, A, B, C, Data[ 0] + LongInt($eaa127fa), 11);
        Round3(C, D, A, B, Data[ 3] + LongInt($d4ef3085), 16);
        Round3(B, C, D, A, Data[ 6] + LongInt($04881d05), 23);
        Round3(A, B, C, D, Data[ 9] + LongInt($d9d4d039),  4);
        Round3(D, A, B, C, Data[12] + LongInt($e6db99e5), 11);
        Round3(C, D, A, B, Data[15] + LongInt($1fa27cf8), 16);
        Round3(B, C, D, A, Data[ 2] + LongInt($c4ac5665), 23);
    
        Round4(A, B, C, D, Data[ 0] + LongInt($f4292244),  6);
        Round4(D, A, B, C, Data[ 7] + LongInt($432aff97), 10);
        Round4(C, D, A, B, Data[14] + LongInt($ab9423a7), 15);
        Round4(B, C, D, A, Data[ 5] + LongInt($fc93a039), 21);
        Round4(A, B, C, D, Data[12] + LongInt($655b59c3),  6);
        Round4(D, A, B, C, Data[ 3] + LongInt($8f0ccc92), 10);
        Round4(C, D, A, B, Data[10] + LongInt($ffeff47d), 15);
        Round4(B, C, D, A, Data[ 1] + LongInt($85845dd1), 21);
        Round4(A, B, C, D, Data[ 8] + LongInt($6fa87e4f),  6);
        Round4(D, A, B, C, Data[15] + LongInt($fe2ce6e0), 10);
        Round4(C, D, A, B, Data[ 6] + LongInt($a3014314), 15);
        Round4(B, C, D, A, Data[13] + LongInt($4e0811a1), 21);
        Round4(A, B, C, D, Data[ 4] + LongInt($f7537e82),  6);
        Round4(D, A, B, C, Data[11] + LongInt($bd3af235), 10);
        Round4(C, D, A, B, Data[ 2] + LongInt($2ad7d2bb), 15);
        Round4(B, C, D, A, Data[ 9] + LongInt($eb86d391), 21);
    
        Inc(Buf[0], A);
        Inc(Buf[1], B);
        Inc(Buf[2], C);
        Inc(Buf[3], D);
    end;
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    procedure MD5UpdateBuffer (
        var MD5Context :TMD5Context;
        Buffer  :Pointer;
        BufSize :Integer);
    var
        BufTmp  :PMD5Buffer;
        BufPtr  :PChar;
        Bytes   :Word;
    begin
        New(BufTmp);
        BufPtr := Buffer;
        { try }
            repeat
                if BufSize > MaxBufSize then
                    Bytes := MaxBufSize
                else
                    Bytes := BufSize;
                Move (BufPtr^, BufTmp^, Bytes);
                Inc (BufPtr, Bytes);
                Dec (BufSize, Bytes);
                if Bytes > 0 then
                    MD5Update (MD5Context, BufTmp^, Bytes);
            until Bytes < MaxBufSize;
        { finally }
            Dispose (BufTmp);
        { end; }
    end;
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    function  {CHUYEN DOI SO HE 10 SANG HE 16 }
    ByteToHex (var bytes :byte) :string2;
    const arrayhex  :array[0..15]of char=('0','1','2','3','4','5','6','7',
                                         '8','9','a','b','c','d','e','f');
    begin
        ByteToHex := arrayhex [bytes shr 4] + arrayhex [bytes and $0f];
    end;
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    function GetMD5 (Buffer :Pointer; BufSize :Integer) :string; {Đây là hàm chính của thư viện}
    var
        I          :Integer;
        MD5Digest  :TMD5Digest;
        MD5Context :TMD5Context;
        addvar     :string;
    begin
        for I := 0 to 15 do
            Byte(MD5Digest[I]) := I + 1;
        MD5Init (MD5Context);
        MD5UpdateBuffer (MD5Context, Buffer, BufSize);
        MD5Final (MD5Digest, MD5Context);
        { Result := ''; }
        addvar :=  '';
        for I := 0 to 15 do
            { Result := Result + IntToHex(Byte(MD5Digest[I]), 2); }
        addvar := addvar + ByteToHex (Byte(MD5Digest[I]));
        GetMD5 := addvar;
    end;
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    {***************************************************************************xx}
    function MD5Str (Buffer :String) :string; 	{Hàm lấy mã md5 của chuỗi}
    begin
        { Result := GetMD5(addr(Buffer[1]), Length(Buffer)); } {Đoạn lệnh cũ delphi}
        MD5Str := GetMD5 (addr(Buffer[1]), Length (Buffer));       {sửa}
    end; 
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    function MD5File (sF :string) :string; 
    var 
        Buffer :TMD5Buffer; 
    	Size   :Longint; 		             
    	vFile  :file;  	
    begin 
    	Assign (vFile,sF); 
    	Reset  (vFile,1); 
    	Size := filesize (vFile); 
        { Writeln ('Size:=',Size);  }
    	If Size <=MaxBufSize then begin             {Nếu FileSize<=16KB thì đọc toàn bộ vào 16KB bộ đệm}
    		Blockread (vFile,Buffer,Size);
    		Close (vFile);
    		MD5File := GetMD5 (addr(Buffer),Size);          {Lấy md5 với size thực}
    		end
    	else begin                                  {nếu filesize>16kb thì chỉ đọc tối đa 16kb vào bộ đệm}
            Blockread (vFile,Buffer,MaxBufSize);
    		Close (vFile);
    		MD5File := GetMD5 (addr(Buffer),MaxBufSize);    {và chỉ lấy md5 của 16KB đầu của file}
    		end;
    end;
    {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
    END.
    Sử dụng:
    - MD5Str (s): lấy mã md5 của 1 chuỗi (password ..v.v.)
    - MD5File (Path): lấy mã md5 của 1 file <=16KB (Với file lớn hơn: )

    Code:
    (*--------------------------------------------------------------------------*)
    USES 
        Crt, 
        MD5; 
    (*--------------------------------------------------------------------------*)
    procedure GetMd5s;
    var s : string;
    begin
        repeat 
            write ('> String:(0=exit) '); readln (s);
            writeln ('   md5(', s, ')=', MD5Str (s));
        until (s='0');
        Delay (2000);
    end;
    (*--------------------------------------------------------------------------*)
    BEGIN
        Writeln ('Ten chuong trinh: ', paramstr (0));
    	Writeln ('md5(path):', MD5Str (paramstr (0)));
    	Writeln ('MD5 VERSION: ', MD5Version);
    	GetMd5s;
    END.
    (*--------------------------------------------------------------------------*)
    Được sửa bởi ada95 lúc 14:22 ngày 18-07-2016
    Unus Pro Omnibus, Omnes Pro Uno

  4. #3
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts

    3. Hiển thị ảnh Bitmap 256 và 16 màu dùng trình điều khiển Svga256.BGI của Borland

    Toàn bộ chương trình:

    Code:
    {
    *
    	Demo chương trình đọc và hiển thị ảnh Bitmap 256 và 16 màu trong Pascal
    	Tác giả: Đỗ Long
    	Ngày 3 tháng 10 năm 2014
    	- Chúc các bạn sớm thành một Pro lập trình nhá ^_^
    *}
    PROGRAM Bmp_Demo_256_16_colors;
    USES Crt, Graph { , vnpascal};
    VAR gd, gm:integer; 
    
    procedure LoadImage (x, y: integer; filename :string);
    var f: file;
    	width, height, offdata, id: longint;
    	bitperpixel, row, col, i, colorinbm: integer;
    	r, g, b, re, color: byte;
    begin
    	assign (f, filename);
    	reset (f, 1);
    	seek (f, 10); blockread (f, offdata, 4);
    	seek (f, 18); blockread (f, width, 4); blockread (f, height, 4);
    	seek (f, 28); blockread (f, bitperpixel, 2);
    	{ Đọc phần palette màu }
    	if bitperpixel=4 then colorinbm:=16
    	else colorinbm:=256;
    	seek (f,54);
    	for i:=0 to colorinbm-1 do
    		begin
    			blockread (f, b, 1); blockread (f, g, 1); blockread (f, r, 1); blockread (f, re, 1); 
    			setrgbpalette (i, r div 4, g div 4, b div 4); 
                {* //Vì các tham số r, g, b của hàm setrgbpalette chỉ có phạm vi
                từ 0-63 nên phải chia cho 4 để lấy giá trị màu gần ảnh nhất *}
    		end;
    	{ Hiển thị ảnh }
    	seek (f, offdata);
    	for row:=0 to height-1 do
    		for col:=0 to width-1 do
    			begin
    				case colorinbm of
    					16:
    						begin
    							id := row*((width+7)div 8)*4+col div 2;
    							seek (f, offdata+id);
    							blockread (f, color, 1);
    							if (col mod 2=0) then color:=color div 16
    							else color:=color mod 16;
    						end;
    					256:
    						begin
    							id:=row*((width+3)div 4)*4+col;
    							seek (f, offdata+id);
    							blockread (f, color, 1);
    						end;
    				end;
    				putpixel (x+col, y+(height-1)-row, color);
    			end;
        close (f);
    end;
    BEGIN
    	{*
         	Đường dẫn thư mục BGI là '' tức là rỗng nên bạn đặt file Svga256.BGI
        vào thư mục Bin của Turbo Pascal
    	hoặc thay initgraph(gd, gm,'');  thành initgraph(gd, gm,"..\BGI"); 
    	rồi copy file Svga256.BGI vào thư mục BGI của Turbo Pascal
    	*}
        gd := installuserdriver ('svga256', nil);
    	if (gd = grError) then halt(1);
    	gm := 2;
    	InitGraph (gd,gm,'');
        
        LoadImage (0,0,'AnhBMP.bmp'); {giả sử ảnh bitmap có tên là AnhBMP.bmp}
        Delay (800);
    
    
        CloseGraph;
    END.
    Chương trình
    http://www.mediafire.com/download/pl...mn5/BMP8bx.zip
    Được sửa bởi ada95 lúc 13:31 ngày 04-08-2016
    Unus Pro Omnibus, Omnes Pro Uno

  5. #4
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts

    4. Phát âm thanh/nhạc định dạng .WAV (phần cứng tương thích SoundBlaster)

    THƯ VIỆN SBWAV TPU

    Code:
    unit SBWAV;
    {****************************************************************************
    ** Unit to play 8bit uncompressed mono WAV files through the Sound Blaster **
    **  by Steven H Don                                                        **
    **                                                                         **
    ** For questions, feel free to e-mail me.                                 **
    **                                                                         **
    **    shd@earthling.net                                                    **
    **    http://shd.cjb.net                                                   **
    **                                                                         **
    ****************************************************************************}
    
    interface
    const 
        SBWAVVERSION:string = '20120715';
    
        function  SBFound : Boolean;
        procedure SBOpen;
        procedure SBClose;
        procedure SBPlay (FileName : String);
        procedure SBStop;
        function  SBLength : LongInt;
        function  SBPlaying : Boolean;
    
    implementation
    
    uses Dos, Crt;
    
    {----------------------------------------------------------------------------
       INTERNAL STUFF
    }
    
    {A WAV header consits of several chunks:}
    type
      RIFFChunkType = record
        RIFF : LongInt;
        NextChunkSize : LongInt;
        RIFFType : LongInt;
      end;
      fmtChunkType = record
        fmt : LongInt;
        fmtLength : LongInt;
        WaveType : Word;
        Channels : Word;
        SampleRate : LongInt;
        BytesPerSecond : LongInt;
        BlockAlignment : Word;
        BitResolution : Word;
      end;
      dataChunkType = record
        data : LongInt;
        dataLength : LongInt;
      end;
    
    var
      {Sound Blaster settings}
      Base       : Word;    {Sound Blaster base address}
      DMA        : Byte;    {The DMA channel}
      IRQ        : Byte;    {The IRQ level}
      OldIRQ     : Pointer; {Pointer to old interrupt routines}
    
      {Memory buffer}
      RBuffer    : Word;    {Read buffer indicator}
      DMABuffer  : Pointer; {Pointer to DMA buffer}
      Page,
      Offset     : Word;
    
      {Header}
      dataChunk  : dataChunkType;
      fmtChunk   : fmtChunkType;
      RIFFChunk  : RIFFChunkType;
    
      {File access}
      WAVFile    : File;    {Handle of the WAV file}
      ToBeRead,             {Amount of samples to be read from file}
      ToBePlayed : LongInt; {Amount of samples to be played}
    
      {Global indicator}
      Playing    : Boolean;
    
    {****************************************************************************
    ** Checks to see if a Sound Blaster exists at a given address, returns     **
    ** true if Sound Blaster found, false if not.                              **
    ****************************************************************************}
    function ResetDSP (Test : Word) : Boolean;
    begin
      {Reset the DSP}
      Port [Test + $6] := 1;
      Delay (10);
      Port [Test + $6] := 0;
      Delay (10);
      {Check if reset was succesfull}
      if (Port [Test + $E] and $80 = $80) and (Port [Test + $A] = $AA) then begin
        {DSP was found}
        ResetDSP := true;
        Base := Test;
      end else
        {No DSP was found}
        ResetDSP := false;
    end;
    
    {****************************************************************************
    ** Send a byte to the DSP (Digital Signal Processor) on the Sound Blaster  **
    ****************************************************************************}
    procedure WriteDSP (Value : byte);
    begin
      {Wait for the DSP to be ready to accept data}
      while Port [Base + $C] and $80 <> 0 do;
      {Send byte}
      Port [Base + $C] := value;
    end;
    
    {****************************************************************************
    ** The DMA controller is programmed with a block length of 32K - the       **
    ** entire buffer. The DSP is instructed to play blocks of 16K and then     **
    ** generate an interrupt (which allows the program to load the next part   **
    ** that should be played).                                                 **
    ****************************************************************************}
    procedure AutoInitPlayback;
    begin
      case DMA of
        0..3 : begin
          Port [$0A] := 4 or DMA;           {Mask DMA channel}
          Port [$0C] := 0;                  {Clear byte pointer}
          Port [$0B] := $58 or DMA;         {Set mode}
          Port [DMA shl 1] := Lo(Offset);   {Write the offset to the DMA controller}
          Port [DMA shl 1] := Hi(Offset);
        end;
      end;
      {
        The mode consists of the following:
        $58+x = binary 01 01 10 xx
                       |  |  |  |
                       |  |  |  +- DMA channel
                       |  |  +---- Read operation (the DSP reads from memory)
                       |  +------- Auto init mode
                       +---------- Block mode
      }
      case DMA of
        0 : Port [$87] := Page;            {Write the page to the DMA controller}
        1 : Port [$83] := Page;            {Write the page to the DMA controller}
        3 : Port [$82] := Page;            {Write the page to the DMA controller}
      end;
    
      case DMA of
        0..3 : begin
          Port [DMA shl 1 + 1] := $FF;     {Set the block length to $7FFF = 32 Kbyte}
          Port [DMA shl 1 + 1] := $7F;
          Port [$0A] := DMA;               {Unmask DMA channel}
        end;
      end;
    
      WriteDSP ($48);                      {Set the block length to $3FFF bytes = 16 Kbyte}
      WriteDSP ($FF);
      WriteDSP ($3F);
    
      WriteDSP ($1C);                      {DSP-command 1Ch - Start auto-init playback}
    end;
    
    procedure SingleCyclePlayback;
    var
      BufOfs : Word;
    
    begin
      dec (ToBePlayed);
      BufOfs := Offset + RBuffer shl 14;
    
      Port [$0A] := 4 or DMA;               {Mask DMA channel}
      Port [$0C] := 0;                      {Clear byte pointer}
      Port [$0B] := $48 or DMA;             {Set mode}
      Port [DMA shl 1] := Lo(BufOfs);       {Write the offset to the DMA controller}
      Port [DMA shl 1] := Hi(BufOfs);
      {
        The mode consists of the following:
        $48+x = binary 01 00 10 xx
                       |  |  |  |
                       |  |  |  +- DMA channel
                       |  |  +---- Read operation (the DSP reads from memory)
                       |  +------- Single cycle mode
                       +---------- Block mode
      }
      case DMA of
        0 : Port [$87] := Page;            {Write the page to the DMA controller}
        1 : Port [$83] := Page;            {Write the page to the DMA controller}
        3 : Port [$82] := Page;            {Write the page to the DMA controller}
      end;
    
      {Set the block length}
      Port [DMA shl 1 + 1] := lo (ToBePlayed);
      Port [DMA shl 1 + 1] := hi (ToBePlayed);
      Port [$0A] := DMA;                   {Unmask DMA channel}
    
      {DSP-command 14h - 8bit single cycle playback}
      WriteDSP ($14);
      WriteDSP (lo (ToBePlayed));
      WriteDSP (hi (ToBePlayed));
    
      {Nothing left to play}
      ToBePlayed := 0;
    end;
    
    {****************************************************************************
    ** Loads one half of the DMA buffer from the file                          **
    ****************************************************************************}
    procedure ReadBuffer (Buffer : Word);
    begin
      {If the remaining part of the file is smaller than 16K,
      load it and fill out with silence}
      if ToBeRead <= 0 then exit;
      if ToBeRead < 16384 then begin
        fillChar (Mem [Seg(DMABuffer^):Ofs(DMABuffer^) + Buffer shl 14], 16384, 128);
        BlockRead (WAVFile, Mem [Seg(DMABuffer^):Ofs(DMABuffer^) + Buffer shl 14], ToBeRead);
        ToBeRead := 0;
      end else begin
        BlockRead (WAVFile, Mem [Seg(DMABuffer^):Ofs(DMABuffer^) + Buffer shl 14], 16384);
        dec (ToBeRead, 16384);
      end;
    end;
    
    {****************************************************************************
    ** IRQ service routine - this is called when the DSP has finished playing  **
    ** a block                                                                 **
    ****************************************************************************}
    procedure ServiceIRQ; interrupt;
    var
      Temp : Byte;
    
    begin
      {Relieve DSP, 8bit port}
      Temp := Port [Base + $E];
      {Acknowledge hardware interrupt}
      Port [$20] := $20;
      {Acknowledge cascade interrupt for IRQ 2, 10 and 11}
      if IRQ in [2, 10, 11] then Port [$A0] := $20;
      {Take appropriate action for buffers}
      if Playing then begin
        dec (ToBePlayed, 16384);
        if ToBePlayed > 0 then begin
          ReadBuffer (RBuffer);
          if ToBePlayed <= 16384 then begin
            RBuffer := RBuffer xor 1;
            SingleCyclePlayback;
          end else if ToBePlayed <= 32768 then begin
            WriteDSP ($DA);
          end;
        end else begin
          Playing := false;
        end;
      end;
    
      RBuffer := RBuffer xor 1;
    end;
    
    {****************************************************************************
    ** This procedure allocates 32K of memory to the DMA buffer and makes sure **
    ** that no page boundary is crossed                                        **
    ****************************************************************************}
    procedure AssignBuffer;
    var
      TempBuf       : Pointer; {Temporary pointer}
      LinearAddress : LongInt;
      Page1, Page2  : Word;
    
    begin
      {Assign 32K of memory}
      GetMem (TempBuf, 32768);
    
      {Calculate linear address}
      LinearAddress := Seg (TempBuf^);
      LinearAddress := LinearAddress shl 4 + Ofs (TempBuf^);
      {Calculate page at start of buffer}
      Page1 := LinearAddress shr 16;
      {Calculate page at end of buffer}
      Page2 := (LinearAddress + 32767) shr 16;
    
      {Check to see if a page boundary is crossed}
      if (Page1 <> Page2) then begin
        {If so, assign another part of memory to the buffer}
        GetMem (DMABuffer, 32768);
        FreeMem (TempBuf, 32768);
      end else begin
        {otherwise, use the part we've already allocated}
        DMABuffer := TempBuf;
      end;
    
      {Convert pointer to linear address}
      LinearAddress := Seg (DMABuffer^);
      LinearAddress := LinearAddress shl 4 + Ofs (DMABuffer^);
      Page := LinearAddress shr 16;
      Offset := LinearAddress and $FFFF;
    end;
    
    {****************************************************************************
    ** This procedure checks the possible addresses to see whether a Sound     **
    ** Blaster is installed.                                                   **
    ****************************************************************************}
    procedure FindSB;
    var
      Temp : Byte;
      BLASTER : String;
    
    begin
      {Nothing found yet}
      Base := 0;
    
      {Check for Sound Blaster, address: ports 210, 220, 230, 240, 250, 260 or 280}
      for Temp := 1 to 8 do begin
        if Temp <> 7 then
        if ResetDSP ($200 + Temp shl 4) then Break;
      end;
      if Temp = 9 then Exit;
    
      {Search for IRQ and DMA entry in BLASTER environment string}
      BLASTER := GetEnv ('BLASTER');
      DMA := 0;
      for Temp := 1 to length (BLASTER) do
        if UpCase (BLASTER [Temp]) = 'D' then
          DMA := Ord (BLASTER [Temp + 1]) - Ord ('0');
      for Temp := 1 to length (BLASTER) do
        if UpCase (BLASTER [Temp]) = 'I' then begin
          IRQ := Ord (BLASTER [Temp + 1]) - Ord ('0');
          if BLASTER [Temp + 2] <> ' ' then
            IRQ := IRQ * 10 + Ord (BLASTER [Temp + 2]) - Ord ('0');
        end;
    end;
    
    {****************************************************************************
    ** This procedure sets up the program according to the values in IRQ and   **
    ** DMA.                                                                    **
    ****************************************************************************}
    procedure InitIRQandDMA;
    begin
      {Save old IRQ vector}
      case IRQ of
        2 : GetIntVec($71, OldIRQ);
       10 : GetIntVec($72, OldIRQ);
       11 : GetIntVec($73, OldIRQ);
      else
        GetIntVec (8 + IRQ, OldIRQ);
      end;
      {Set new IRQ vector}
      case IRQ of
        2 : SetIntVec($71, Addr (ServiceIRQ));
       10 : SetIntVec($72, Addr (ServiceIRQ));
       11 : SetIntVec($73, Addr (ServiceIRQ));
      else
        SetIntVec (8 + IRQ, Addr (ServiceIRQ));
      end;
      {Enable IRQ}
      case IRQ of
        2 : Port [$A1] := Port [$A1] and not 2;
       10 : Port [$A1] := Port [$A1] and not 4;
       11 : Port [$A1] := Port [$A1] and not 8;
      else
        Port [$21] := Port [$21] and not (1 shl IRQ);
      end;
      if IRQ in [2, 10, 11] then Port [$21] := Port [$21] and not 4;
    end;
    
    {****************************************************************************
    ** This procedure releases the DMA channel and IRQ level                   **
    ****************************************************************************}
    procedure ReleaseIRQandDMA;
    begin
      {Free interrupt vectors used to service IRQs}
      case IRQ of
        2 : SetIntVec($71, OldIRQ);
       10 : SetIntVec($72, OldIRQ);
       11 : SetIntVec($73, OldIRQ);
      else
        SetIntVec (8 + IRQ, OldIRQ);
      end;
    
      {Mask IRQs}
      case IRQ of
        2 : Port [$A1] := Port [$A1] or 2;
       10 : Port [$A1] := Port [$A1] or 4;
       11 : Port [$A1] := Port [$A1] or 8;
      else
        Port [$21] := Port [$21] or (1 shl IRQ);
      end;
      if IRQ in [2, 10, 11] then Port [$21] := Port [$21] or 4;
    end;
    
    {----------------------------------------------------------------------------
       EXTERNALLY VISIBLE FUNCTIONS
    }
    
    {****************************************************************************
    ** This procedure returns true if the Sound Blaster is present.            **
    ****************************************************************************}
    function SBFound : Boolean;
    begin
      SBFound := Base <> 0;
    end;
    
    {****************************************************************************
    ** This procedure initialises the Sound Blaster                            **
    ****************************************************************************}
    procedure SBOpen;
    begin
      {Set up IRQ and DMA channels}
      InitIRQandDMA;
    
      {Assign memory to the DMA Buffer}
      AssignBuffer;
    
      {Set read buffer to first buffer}
      RBuffer := 0;
      Playing := false;
    end;
    
    {****************************************************************************
    ** This procedure gracefully shuts down the unit.                          **
    ****************************************************************************}
    procedure SBClose;
    begin
      {Stop any operation in progress}
      if Playing then SBStop;
      {Release the memory buffer}
      FreeMem (DMABuffer, 32768);
      {Release the IRQ and DMA channels}
      ReleaseIRQandDMA;
    end;
    
    {****************************************************************************
    ** Starts playing a WAV file.                                              **
    ****************************************************************************}
    procedure SBPlay (FileName : String);
    var
      Before : LongInt;
    
    begin
      {Don't play if there's no buffer}
      if (DMABuffer = nil) then Exit;
    
      {Start playback in buffer 0 and clear the buffer}
      RBuffer := 0;
      fillChar (DMABuffer^, 32768, 128);
    
      {Open the file for output}
      Assign (WAVFile, FileName);
    
      {$I-}
      Reset (WAVFile, 1);
      if (IOResult <> 0) then Exit;
    
      {Read RIFF chunk}
      BlockRead (WAVFile, RIFFChunk, sizeof (RIFFChunk));
      if (RIFFChunk.RIFF <> $46464952) or (RIFFChunk.RIFFType <> $45564157) then begin
        Close (WAVFile);
        exit;
      end;
    
      {Read fmt chunk}
      repeat
        Before := FilePos (WAVFile);
        BlockRead (WAVFile, fmtChunk, sizeof (fmtChunk));
        Seek (WAVFile, Before + fmtChunk.fmtLength + 8);
      until (fmtChunk.fmt = $20746D66);
    
      {Set playback frequency}
      WriteDSP ($40);
      WriteDSP (256 - 1000000 div fmtChunk.SampleRate);
    
      {Read data chunk}
      repeat
        Before := FilePos (WAVFile);
        BlockRead (WAVFile, dataChunk, sizeof (dataChunk));
        if (dataChunk.data <> $61746164) then
          Seek (WAVFile, Before + dataChunk.dataLength + 8);
      until (dataChunk.data = $61746164);
      ToBePlayed := dataChunk.dataLength;
      ToBeRead := ToBePlayed;
    
      {DSP-command D1h - Enable speaker}
      WriteDSP ($D1);
    
      {Read first bit of data}
      ReadBuffer (0);
      ReadBuffer (1);
    
      if (ToBeRead > 0) then AutoInitPlayback
      else SingleCyclePlayback;
      {$I+}
    
      Playing := true;
    end;
    
    {****************************************************************************
    ** Stops playback                                                          **
    ****************************************************************************}
    procedure SBStop;
    begin
      {Stops DMA-transfer}
      WriteDSP ($D0);
    
      {Playback has completed}
      Playing := false;
    
      {Close the file}
      {$I-}
      Close (WAVFile);
      if IOResult = 0 then;
      {$I+}
    end;
    
    {****************************************************************************
    ** This procedure returns the length of the WAV file in whole seconds.     **
    ****************************************************************************}
    function SBLength : LongInt;
    begin
      SBLength := dataChunk.dataLength div fmtChunk.BytesPerSecond;
    end;
    
    {****************************************************************************
    ** This procedure returns true if the WAV is still playing.                **
    ****************************************************************************}
    function SBPlaying : Boolean;
    begin
      SBPlaying := Playing;
    end;
    
    begin
      FindSB;
    end.
    TEST

    Code:
    {
    -- File: TEST.WAV cùng thư mục
    -- và có định dạng: WAV 8bit không nén, kênh đơn
    }
    
    USES Crt, SBWav;
    BEGIN    
        if not SBWav.SBFound then begin            {Check for Sound Blaster}
            Writeln ('Sound Blaster not found.');
            Delay (2000);  
            Halt;
        end;
        
        SBWav.SBOpen;                   {Initialise Sound Blaster}
        SBWav.SBPlay ('TEST.WAV');  {Play a file}
        repeat
        until (not SBWav.SBPlaying);
        
        SBWav.SBStop;
        SBWav.SBClose;                   {Close Sound Blaster}
    END.
    Được sửa bởi ada95 lúc 14:25 ngày 18-07-2016 Reason: Thay <dot> thành '.'

  6. #5
    Tham gia
    27-01-2016
    Location
    THCS Phan Đăng Lưu
    Bài viết
    57
    Like
    1
    Thanked 92 Times in 39 Posts
    Thư viện là uses crt

  7. Thành viên Like bài viết này:


  8. #6
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts

    5.Nén file dùng thuật toán huffman/LZH

    Thư viện LZH.TPU
    Code:
    { LZHUF.C English version 1.0
      Based on Japanese version 29-NOV-1988
      LZSS coded by Haruhiko OKUMURA
      Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
      Edited and translated to English by Kenji RIKITAKE
      Converted to Turbo Pascal 5.0
        by Peter Sawatzki with assistance of Wayne Sullivan
    }
    {$i-,r-,v-,s-}
    Unit LZH;
    Interface
    type
        bufar = array [0..0] of byte; {will be overindexed}
    var
        WriteFromBuffer,
        ReadToBuffer    :procedure;
        inbuf,outbuf    :^bufar;
        inptr,inend,outptr,outend :word;
    
    procedure Encode (bytes :LongInt);
    procedure Decode;
    
    Implementation
    Const
        {-LZSS Parameters}
        N         = 4096; {Size of string buffer}
        F         = 60;   {60 Size of look-ahead buffer}
        THRESHOLD = 2;
        NODENIL   = N;    {End of tree's node}
    
        {-Huffman coding parameters}
        N_CHAR    = 256-THRESHOLD+F;
                    {character code (= 0..N_CHAR-1)}
        T         = N_CHAR*2 -1;  {Size of table}
        R         = T-1;          {root position}
        MAX_FREQ  = $8000; {update when cumulative frequency reaches to this value}
    
        {-Tables for encoding/decoding upper 6 bits of sliding dictionary pointer}
        {-encoder table}
    p_len: array[0..63] of byte =
           ($03,$04,$04,$04,$05,$05,$05,$05,$05,$05,$05,$05,$06,$06,$06,$06,
            $06,$06,$06,$06,$06,$06,$06,$06,$07,$07,$07,$07,$07,$07,$07,$07,
            $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
            $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08);
    
    p_code: array[0..63] of byte =
           ($00,$20,$30,$40,$50,$58,$60,$68,$70,$78,$80,$88,$90,$94,$98,$9C,
            $A0,$A4,$A8,$AC,$B0,$B4,$B8,$BC,$C0,$C2,$C4,$C6,$C8,$CA,$CC,$CE,
            $D0,$D2,$D4,$D6,$D8,$DA,$DC,$DE,$E0,$E2,$E4,$E6,$E8,$EA,$EC,$EE,
            $F0,$F1,$F2,$F3,$F4,$F5,$F6,$F7,$F8,$F9,$FA,$FB,$FC,$FD,$FE,$FF);
    
    {-decoder table}
    d_code: array[0..255] of byte =
           ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
            $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
            $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,
            $02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,
            $03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
            $04,$04,$04,$04,$04,$04,$04,$04,$05,$05,$05,$05,$05,$05,$05,$05,
            $06,$06,$06,$06,$06,$06,$06,$06,$07,$07,$07,$07,$07,$07,$07,$07,
            $08,$08,$08,$08,$08,$08,$08,$08,$09,$09,$09,$09,$09,$09,$09,$09,
            $0A,$0A,$0A,$0A,$0A,$0A,$0A,$0A,$0B,$0B,$0B,$0B,$0B,$0B,$0B,$0B,
            $0C,$0C,$0C,$0C,$0D,$0D,$0D,$0D,$0E,$0E,$0E,$0E,$0F,$0F,$0F,$0F,
            $10,$10,$10,$10,$11,$11,$11,$11,$12,$12,$12,$12,$13,$13,$13,$13,
            $14,$14,$14,$14,$15,$15,$15,$15,$16,$16,$16,$16,$17,$17,$17,$17,
            $18,$18,$19,$19,$1A,$1A,$1B,$1B,$1C,$1C,$1D,$1D,$1E,$1E,$1F,$1F,
            $20,$20,$21,$21,$22,$22,$23,$23,$24,$24,$25,$25,$26,$26,$27,$27,
            $28,$28,$29,$29,$2A,$2A,$2B,$2B,$2C,$2C,$2D,$2D,$2E,$2E,$2F,$2F,
            $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3A,$3B,$3C,$3D,$3E,$3F);
    
    d_len: array[0..255] of byte =
           ($03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
            $03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
            $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
            $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
            $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
            $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
            $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
            $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
            $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
            $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
            $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
            $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
            $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
            $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
            $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
            $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08);
    
        getbuf: word = 0;
        getlen: byte = 0;
        putbuf: word = 0;
        putlen: word = 0;
    
        textsize: LongInt = 0;
        codesize: LongInt = 0;
        printcount: LongInt = 0;
    
    var
        text_buf: array [0..N + F - 2] of byte;
        match_position, match_length :word;
        lson, dad: array [0..N] of word;
        rson:     array [0..N + 256] of word;
    
        freq: array [0..T] of word; {cumulative freq table}
    
        {-pointing parent nodes. area [T..(T + N_CHAR - 1)] are pointers for leaves}
        prnt: array [0..T+N_CHAR-1] of word;
    
        {-pointing children nodes (son[], son[] + 1)}
        son: array [0..T-1] of word;
    
    function getc :byte;
    begin
        getc := inbuf^[inptr];
        Inc (inptr);
        if inptr = inend then ReadToBuffer
    end;
    
    procedure putc (c :byte);
    begin
        outbuf^[outptr] := c;
        Inc (outptr);
        if outptr = outend then
        WriteFromBuffer
    end;
    
    procedure InitTree;
    {-Initializing tree}
    var
        i: word;
    begin
        for i:= N+1 to N+256 do rson [i] := NODENIL; {root}
        for i:= 0 to N-1 do     dad [i]  := NODENIL; {node}
    end;
    
    procedure InsertNode (r :word);
    {-Inserting node to the tree}
    Label
        Done;
    var
        i, p    :word;
        geq     :boolean;
        c         :word;
    begin
        geq := true;
        p := N+1+text_buf [r];
        rson [r]:= NODENIL;
        lson [r]:= NODENIL;
        match_length := 0;
        while TRUE do begin
        if geq then
        if rson [p] = NODENIL then begin
        rson [p]:= r;
        dad [r] := p;
        exit
        end else
        p:= rson[p]
        else
        if lson [p]=NODENIL then begin
        lson [p]:= r;
        dad [r] := p;
        exit
        end else
        p:= lson [p];
        i:= 1;
        while (i < F) AND (text_buf [r+i] = text_buf [p+i]) do Inc(i);
        geq:= (text_buf [r+i] >= text_buf [p+i]) or (i=F);
    
        if i > THRESHOLD then begin
        if i > match_length then begin
        match_position := (r-p) AND (N-1) -1;
        match_length:= i;
        if match_length >= F then goto done;
        end;
        if i = match_length then begin
        c:= (r-p) AND (N-1) -1;
        if c < match_position then match_position:= c
        end
        end
        end;
        Done:
        dad [r]:= dad[p];
        lson[r]:= lson[p];
        rson[r]:= rson[p];
        dad [lson[p]]:= r;
        dad [rson[p]]:= r;
        if rson [dad [p]] = p then
        rson [dad [p]]:= r
        else
        lson [dad [p]]:= r;
        dad [p]:= NODENIL; {remove p}
    end;
    
    procedure DeleteNode (p :word);
    {-Delete node from the tree}
    var
        q :word;
    begin
        if dad[p] =NODENIL then exit; {unregistered}
        if rson[p]=NODENIL then q:= lson[p] else
        if lson[p]=NODENIL then q:= rson[p] else begin
        q:= lson[p];
        if rson [q] <> NODENIL then begin
        repeat
            q := rson [q];
        until rson [q]=NODENIL;
        rson [dad [q]]:= lson [q];
        dad [lson [q]]:= dad [q];
        lson [q]:= lson [p];
        dad [lson [p]]:= q;
        end;
        rson [q]:= rson [p];
        dad [rson [p]]:= q;
        end;
        dad [q] := dad [p];
        if rson [dad [p]]=p then
        rson [dad [p]]:= q
        else
        lson [dad [p]]:= q;
        dad [p] := NODENIL;
    end;
    
    function GetBit :byte;
    {-get one bit}
    begin
        while getlen <= 8 do begin
            getbuf := getbuf OR (WORD (getc) SHL (8-getlen));
            Inc (getlen, 8);
            end;
        GetBit := getbuf SHR 15;
        {if (getbuf AND $8000)>0 then GetBit:= 1 else GetBit:= 0;}
        getbuf := getbuf SHL 1;
        Dec (getlen);
    end;
    
    function GetByte: Byte;
    {-get a byte}
    begin
        while getlen <= 8 do begin
            getbuf := getbuf OR (WORD (getc) SHL (8 - getlen));
            Inc (getlen, 8);
            end;
        GetByte := Hi (getbuf);
        getbuf := getbuf SHL 8;
        Dec (getlen, 8);
    end;
    
    procedure Putcode (l :byte; c :word);
    {-output l bits}
    begin
        putbuf := putbuf OR (c SHR putlen);
        Inc (putlen, l);
        if putlen >= 8 then begin
            putc (Hi (putbuf));
            Dec (putlen, 8);
            if putlen >= 8 then begin
                putc (Lo (putbuf));
                Inc (codesize, 2);
                Dec (putlen, 8);
                putbuf := c SHL (l-putlen);
                end 
            else begin
                putbuf := Swap (putbuf AND $FF); {SHL 8;}
                Inc (codesize);
                end
            end
    end;
    
    procedure StartHuff;
    {-initialize freq tree}
    var
        i,j :word;
    begin
        for i:= 0 to N_CHAR-1 do begin
            freq [i]:= 1;
            son [i] := i+T;
            prnt [i+T]:= i
            end;
        i:= 0; j:= N_CHAR;
        while j <= R do begin
            freq [j]:= freq [i]+freq [i+1];
            son [j] := i;
            prnt [i]:= j;
            prnt [i+1]:= j;
            Inc (i,2); Inc (j)
            end;
        freq [T]:= $FFFF;
        prnt [R]:= 0;
    end;
    
    procedure reconst;
    {-reconstruct freq tree }
    var
        i,j,k,f,l :word;
    begin
        {-halven cumulative freq for leaf nodes}
        j := 0;
        for i:= 0 to T-1 do
            if son [i] >= T then begin
            freq [j]:= (freq [i]+1) SHR 1;
            son [j] := son [i];
            Inc (j)
            end;
        {-make a tree : first, connect children nodes}
        i:= 0; j:= N_CHAR;
        while j < T do begin
            k:= i+1;
            f:= freq [i]+freq [k];
            freq [j]:= f;
            k:= j-1;
            while f < freq [k] do Dec (k);
            Inc (k);
            l := (j-k)*2;
    
            move (freq [k],freq [k+1],l);
            freq [k]:= f;
            move (son [k],son [k+1],l);
            son [k]:= i;
            Inc (i,2);
            Inc (j)
            end;
        {-connect parent nodes}
        for i:= 0 to T-1 do begin
            k := son [i];
            prnt [k]:= i;
            if k < T then
            prnt [k+1]:= i
            end
    end;
    
    procedure update (c :word);
    {-update freq tree}
    var
        i,j,k,l :word;
    begin
        if freq [R] = MAX_FREQ then reconst;
        c:= prnt [c+T];
        repeat
            Inc (freq [c]);
            k := freq [c];
            {-swap nodes to keep the tree freq-ordered}
            l:= c+1;
            if k > freq [l] then begin
                while k > freq [l+1] do Inc (l);
                freq [c]:= freq [l];
                freq [l]:= k;
    
                i:= son [c];
                prnt [i]:= l;
                if i<T then prnt [i+1]:= l;
    
                j:= son [l];
                son [l]:= i;
    
                prnt [j]:= c;
                if j<T  then prnt [j+1]:= c;
                son [c]:= j;
    
                c := l;
                end;
            c:= prnt [c]
        until c=0; {do it until reaching the root}
    end;
    
    procedure EncodeChar (c :word);
    var
        code,len,k :word;
    begin
        code := 0;
        len := 0;
        k := prnt [c+T];
        {-search connections from leaf node to the root}
        repeat
            code := code SHR 1;
            {-if node's address is odd, output 1 else output 0}
            if (k AND 1) > 0 then Inc (code, $8000);
            Inc (len);
            k:= prnt [k];
        until k=R;
        Putcode (len, code);
        update (c)
    end;
    
    procedure EncodePosition (c :word);
    var
        i: word;
    begin
        {-output upper 6 bits with encoding}
        i:= c SHR 6;
        Putcode (p_len [i], WORD (p_code [i]) SHL 8);
        {-output lower 6 bits directly}
        Putcode (6, (c AND $3F) SHL 10);
    end;
    
    procedure EncodeEnd;
    begin
        if putlen > 0 then begin
        putc (Hi (putbuf));
        Inc (codesize)
        end
    end;
    
    function DecodeChar :word;
    var
        c: word;
    begin
        c:= son [R];
        {-start searching tree from the root to leaves.
        choose node #(son[]) if input bit = 0
        else choose #(son[]+1) (input bit = 1)}
        while c<T do c:= son [c+GetBit];
        Dec (c,T);
        update (c);
        DecodeChar := c
    end;
    
    function DecodePosition :word;
    var
        i,j,c :word;
    begin
        {-decode upper 6 bits from given table}
        i:= GetByte;
        c:= WORD (d_code [i]) SHL 6;
        j:= d_len [i];
        {-input lower 6 bits directly}
        Dec (j, 2);
        while j>0 do begin
            Dec (j);
            i:= (i SHL 1) OR GetBit;
            end;
        DecodePosition := c OR (i AND $3F);
    end;
    
    {-Compression }
    procedure Encode (bytes :LongInt);
    {-Encoding/Compressing}
    type
        ByteRec = record
        b0,b1,b2,b3 :byte
        end;
    var
        i,c,len,r,s,last_match_length :word;
    begin
        {-write size of original text}
        with ByteRec (Bytes) do begin
            putc (b0);
            putc (b1);
            putc (b2);
            putc (b3)
            end;
        if bytes=0 then exit;
        textsize := 0;
        StartHuff;
        InitTree;
        s := 0;
        r := N-F;
        fillchar (text_buf [0], r,' ');
        len := 0;
        while (len<F) AND (inptr OR inend>0) do begin
            text_buf [r+len]:= getc;
            Inc (len)
            end;
        textsize := len;
        for i:= 1 to F do InsertNode (r - i);
        InsertNode (r);
        repeat
            if match_length > len then match_length:= len;
            if match_length <= THRESHOLD then begin
                match_length := 1;
                EncodeChar (text_buf [r])
                end 
                else begin
                EncodeChar (255 - THRESHOLD + match_length);
                EncodePosition (match_position)
                end;
            last_match_length := match_length;
            i:= 0;
            while (i < last_match_length) AND (inptr OR inend > 0) do begin
                Inc(i);
                DeleteNode (s);
                c:= getc;
                text_buf [s]:= c;
                if s < (F-1) then text_buf [s+N]:= c;
                s:= (s+1) AND (N-1);
                r:= (r+1) AND (N-1);
                InsertNode (r);
                end;
            Inc (textsize, i);
            if textsize > printcount then begin
                write (textsize,#13);
                Inc (printcount,1024)
                end;
            while i < last_match_length do begin
                Inc (i);
                DeleteNode (s);
                s := (s+1) AND (N-1);
                r := (r+1) AND (N-1);
                Dec (len);
                if len > 0 then InsertNode (r)
                end;
        until len=0;
        EncodeEnd;
        writeln ('input:  ',textsize,' bytes');
        writeln ('output: ',codesize,' bytes');
        writeln ('compression: ', textsize*100 DIV codesize,'%');
    end;
    
    procedure Decode;
    {-Decoding/Uncompressing}
    type
        ByteRec = Record
        b0,b1,b2,b3 :byte
        end;
    var
        i,j,k,r,c :word;
        count    :LongInt;
    begin
        {-read size of original text}
        with ByteRec (textsize) do begin
            b0:= getc;
            b1:= getc;
            b2:= getc;
            b3:= getc
            end;
        if textsize=0 then exit;
        StartHuff;
        fillchar (text_buf [0], N-F,' ');
        r:= N-F;
        count:= 0;
        while count < textsize do begin
        c := DecodeChar;
        if c<256 then begin
            putc (c);
            text_buf [r]:= c;
            r := (r+1) AND (N-1);
            Inc (count)
            end 
        else begin
            i:= (r-DecodePosition-1) AND (N-1);
            j:= c-255+THRESHOLD;
            for k:= 0 to j-1 do begin
                c:= text_buf [(i+k) AND (N-1)];
                putc (c);
                text_buf [r]:= c;
                r:= (r+1) AND (N-1);
                Inc (count)
                end;
            end;
        if count > printcount then begin
            write (count,#13);
            Inc (printcount,1024)
            end
        end;
        writeln(count);
    end;
    
    end.
    Chương trình test:
    Code:
    {$A+,B-,D+,E+,F-,I-,L+,N+,O-,R-,S-,V-}
    {$M 16384,0,655360}
    PROGRAM LZH_01;
    USES
        LZH;
    TYPE
        IObuf = array [0..10*1024-1] of byte;
    VAR
        infile, outfile :file;
        ibuf, obuf :IObuf;
        s :String;
    
        procedure Error (msg :String);
        begin
            writeln (msg);
            HALT (1)
        end;
    
        {$F+}
        procedure ReadNextBlock;
        {$F-}
        begin
            LZH.inptr := 0;
            BlockRead (infile, LZH.inbuf^, sizeof (ibuf), LZH.inend);
            if IoResult > 0 then Error ('! Error reading input file');
        end;
            
        {$F+}
        procedure WriteNextBlock;
        {$F-}
        var
            wr :word;
        begin
            BlockWrite (outfile, LZH.outbuf^, LZH.outptr, wr);
            if (IoResult > 0) or (wr < LZH.outptr) then
            Error ('! Error writing output file');
            LZH.outptr := 0
        end;
        { procedure OpenInput (fn :String);
        begin
            assign (infile, fn); reset (infile, 1);
            if IoResult > 0 then Error ('! Can''t open input file');
            LZH.inbuf := @ibuf;
            LZH.ReadToBuffer := ReadNextBlock;
            LZH.ReadToBuffer;
        end; }
        function OpenInput (fn :String) :boolean;
        begin
            assign (infile, fn); reset (infile, 1);
            OpenInput := (IoResult <= 0) ;
            LZH.inbuf := @ibuf;
            LZH.ReadToBuffer := ReadNextBlock;
            LZH.ReadToBuffer;
        end;
        { procedure OpenOutput (fn :String);
        begin
            assign (outfile, fn); rewrite (outfile, 1);
            if IoResult > 0 then Error ('! Can''t open output file');
            LZH.outbuf:= @obuf;
            LZH.outend:= sizeof (obuf);
            LZH.outptr:= 0;
            LZH.WriteFromBuffer := WriteNextBlock; 
        end;}
        function OpenOutput (fn :String) :boolean;
        begin
            assign (outfile, fn); rewrite (outfile, 1);
            OpenOutput := (IoResult <= 0);
            LZH.outbuf:= @obuf;
            LZH.outend:= sizeof (obuf);
            LZH.outptr:= 0;
            LZH.WriteFromBuffer := WriteNextBlock;
        end;
    BEGIN {MAIN}
        if ParamCount <> 3 then begin
            writeln ('Usage: lzhuf infile outfile e(compression)|d(uncompression)');
            HALT (1)
        end;
        OpenInput (ParamStr (1));
        OpenOutput (ParamStr (2)); 
        
        s := ParamStr (3);
        case s [1] of
            'e','E': Encode (filesize (infile));
            'd','D': Decode
            else
            Error ('! Use [D] for Decompression or [E] for Compression')
            end;
        close (infile); if IoResult > 0 then Error ('! Error closing input file');
        if LZH.outptr > 0 then WriteNextBlock;
        close (outfile); if IoResult > 0 then Error ('! Error closing output file');
    END.
    Chương trình đã biên dịch:
    http://www.mediafire.com/download/m7...sse/lzh_01.zip
    Được sửa bởi ada95 lúc 13:33 ngày 04-08-2016

  9. #7
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts

    6. Hiển thị ảnh BITMAP 16 triệu màu

    Thư viện bmp.tpu

    Code:
    Unit BMP;
    Interface
    Uses Dos, Crt;
    const
        BMPVERSION :string = '20120715';
    type
        NullString  = array [0.. 255] of Char;
        ModeList    = array [1..3277] of Word;
        
        SVGAInformation = record
            Signature       :array [1..4] of Char;
            Version         :Word;
            OEMStringPtr    :^NullString;
            Capabilities    :LongInt;
            VideoModePtr    :^ModeList;
            TotalMemory     :Integer;
            OEMSoftwareRev  :Integer;
            OEMVendorNamePtr:Pointer;
            OEMProductNamePtr:Pointer;
            OEMProductRevPtr:Pointer;
            Reserved        :array [1..222] of Byte;
            OEMData         :array [1..256] of Byte;
            end;
        
        SVGAMode = record
            ModeAttributes  :Word;
            WinAAttributes  :Byte;
            WinBAttributes  :Byte;
            WinGranularity  :Integer;
            WinSize         :Word;
            WinASegment     :Word;
            WinBSegment     :Word;
            WinFunctionPtr  :procedure;
            BytesPerScanLine:Integer;
            XResolution     :Integer;
            YResolution     :Integer;
            XCharSize       :Byte;
            YCharSize       :Byte;
            NumberOfPlanes  :Byte;
            MemoryModel     :Byte;
            BankSize        :Byte;
            NumberOfImagePages :Byte;
            Reserved1       :Byte;
            RedMaskSize     :Byte;
            RedFieldPosition:Byte;
            GreenMaskSize   :Byte;
            GreenFieldPosition  :Byte;
            BlueMaskSize        :Byte;
            BlueFieldPosition   :Byte;
            RsvdMaskSize        :Byte;
            RsvdFieldPosition   :Byte;
            DirectColorModeInfor:Byte;
            PhysicalBasePtr     :Pointer;
            OffScreenMemOffse   :Pointer;
            OffScreenMemSize    :Integer;
            Reserved: array [1..206] of Byte;
            end;
    var
        VesaInfor       :SVGAInformation;
        VesaModeInfor   :SVGAMode;
        MaxX, MaxY      :Word;
        BitPerPixel     :Byte;
        Seg_, Ofs_      :Word;
        BytePerPixel    :Word;
        BytePerLine     :Integer;
                x_      :Word;
            P, PO       :Word;
                DP      :Byte;
    Type
        ColorReg=Record
            Red1  :Byte;
            Green1:Byte;
            Blue1 :Byte;
            End;
    
            TColor = record
                b, g, r :Byte;
                end;
    {----------------------------------}
        TArray256=Array [0..255] of ColorReg;
        TArray16=Array [0..15] of ColorReg;
        ExtendedPalette = Record
            ExtendedPalette :Byte;
            (* Max size of 768 bytes *)
            ExPalette :TArray256;
            End;
    {----------------------------------}
    	BMPColorReg=Record
            biBlue    :Byte;
            biGreen   :Byte;
            biRed     :Byte;
            biReserve :Byte;
            End;
    {----------------------------------}
        TBitmapHeader=Record
            bfType :Array [1..2] of char;
            bfSize :longint;
            bfReserve :Array [1..4] of char;
            bfOffBits :longint;
            End;
    {----------------------------------}
        TBitmapInfoHeader = record
            Size    :Longint;
            Width   :Longint;
            Height  :Longint;
            Planes  :Word;
            BitCount:Word;
            Compression  :Longint;
            SizeImage    :Longint;
            XPelsPerMeter:Longint;
            YPelsPerMeter:Longint;
            ClrUsed      :Longint;
            ClrImportant :Longint;
            end;
    {----------------------------------}
    	TBMPPalette     = Array [0.. 15] of BMPColorReg;
        TBMPPalette256  = Array [0..255] of BMPColorReg;
    {----------------------------------}
    Var
        BMPHdr      :TBitmapHeader;
        BMPIf       :TBitmapInfoHeader;
        BMPPalette  :TBMPPalette;
        BMP256      :TBMPPalette256;
        BMPMode     :Byte;
    
        DirectVideo :Word;
    Const
        GraphOn     :Word=0;
        GraphOff    :Word=1;
    
    {-------------------------------------------------------------------------}  
    Procedure   SetVideo (Vid,Dr :Word);
                { Set Video Mode and turn Graphics On or Off }
    Procedure   WritePixel (Col,Row :Word; Color :Byte);
                { Draw a pixel at column Col,row Row with color Color }
    function    GetVesaInfor :Boolean;
    function    GetModeInfor (Mode :Word) :Boolean;
    function    FindMode (x, y :Word; b :Byte) :Word;
    function    InitGraph (x, y :Word; b :Byte) :Boolean;
    procedure   PutPixel (x, y :Word; r, g, b :Byte);
    Procedure   LoadBMP8bit (FileName :String);
    procedure   LoadBMP24bit (PosX, PosY :Integer; FileName :string; Delays :word);
    function    CloseGraph :Boolean;
    {procedure   Delayss (t :byte);}
    {-------------------------------------------------------------------------}
    IMPLEMENTATION
    {-------------------------------------------------------------------------}
    Procedure SetVideo (Vid, Dr :Word); assembler;
    asm
        mov ax,Vid
        int 10h
        mov ax,Dr
        mov DirectVideo,ax
    End;
    (*-------------------------*)
    Procedure WritePixel (Col, Row :Word; Color :Byte); assembler;
    asm
        mov ah,0ch
        mov al,Color
        mov bh,0
        mov cx,Col
        mov dx,Row
        int 10h
    end;
    (*-------------------------*)
    Procedure IncPoint (Var P :Pointer; t :longint);
    Begin
       P := Ptr (Seg (P^), Ofs (P^)+t)
    End;
    (*-------------------------*)
    Procedure Install256 (Array256 :TArray256); assembler;
    asm
        mov bx,Seg Array256
        mov es,bx
        xor bx,bx  
        mov dx,Offset Array256
        mov ah,10h              { Set Block of Color Registers }
        mov al,12h
        mov cx,256              { CX:=256 }   
        int 10h
    end;
    (*-------------------------*)
    Procedure Install16 (Array16 :TArray16); assembler;
    asm
        mov bx,Seg Array16
        mov es,bx
        xor bx,bx
        mov dx,Offset Array16
        mov ah,10h              { Set Block of Color Registers }
        mov al,12h
        mov cx,16               { CX:=16 }
        int 10h
    end;
    (*-------------------------*)
    Procedure InstallBMP;
    Var 
        i           :Word;
        Palette16   :TArray16;
        Palette256  :TArray256;
        AllPlt      :Array [0..16] of Shortint;
    	R           :Dos.Registers;
    Begin
        If BMPIf.BitCount <> 8 then begin
            For i:=0 to 15 do begin
              Palette16[i].Red1   :=BMPPalette[i].biRed   shr 2;
              Palette16[i].Green1 :=BMPPalette[i].biGreen shr 2;
              Palette16[i].Blue1  :=BMPPalette[i].biBlue  shr 2;
            End;
            AllPlt [16]:=0;
            For i:=0 to 15 do AllPlt [i]:=i;
            With R do begin
               AH:=$10;
               AL:=2;
               ES:=Seg (AllPlt);
               DX:=Ofs (AllPlt);
               Intr ($10,R)
            End;
            Install16 (Palette16)
        End{If}
        Else begin
            For i:=0 to 255 do begin
              Palette256[i].Red1  :=BMP256[i].biRed   shr 2;
              Palette256[i].Green1:=BMP256[i].biGreen shr 2;
              Palette256[i].Blue1 :=BMP256[i].biBlue  shr 2;
            End;
            Install256(Palette256);
        End
    End;
    (*-------------------------*)
    Procedure LoadBMP8bit (FileName :String);
    Const
        BufSize :Word=65535;
    Var
        Buffer,P:Pointer;
        f :File;
        i,Result,ReadRs,NumRead,ByteLine :word;
        b,k,NumS,Mask,Bc :byte;
        j :integer;
        HorLimit,VerLimit,MaxH,MaxV,RealyByte :Word;
    Begin
        Assign (f,FileName);
        {$I-}
        Reset (f,1);
        If IOResult <>0 then Exit;
        {$I+}
        BlockRead (f, BMPHdr, Sizeof (BMPHdr));
        BlockRead (f, BMPIf, Sizeof (BMPIf));
        If BMPIf.BitCount <>8 then BlockRead (f, BMPPalette, Sizeof (BMPPalette))
        Else BlockRead (f, BMP256, Sizeof (BMP256));
    
        If (BMPHdr.bfType <>'BM') then begin
          Close (f);
    	  Write (FileName,' is not BMP file.');
    	  {Repeat;
    	  Until KeyPressed;}
          Exit
    	End;
          
        Seek (f, BMPHdr.bfOffBits);
        While MaxAvail < BufSize do Dec (BufSize);
        If (BMPIf.BitCount <> 8) then begin
          BMPMode:=$12;
          MaxH:=640;
          MaxV:=480;
        End
        Else begin
          MaxH:=320;
          MaxV:=200;
          BMPMode:=$13   
        End;
        { SetVideo (BMPMode,GraphOn); } {Tôi đưa ra ngoài chương trình chính}
        InstallBMP;
        Getmem (Buffer,BufSize);
        P:=Buffer;
        NumRead:=0;
        BlockRead (f,Buffer^,BufSize,Result);
    
    
        If BMPIf.Width <= MaxH then ByteLine:=BMPIf.Width
        Else ByteLine:=MaxH;
    
        HorLimit:=ByteLine-1;
        VerLimit:=0;
    
    	If BMPIf.Height <= MaxV then j:=BMPIf.Height-1
        Else j:=MaxV-1;
        i:=0;
        Bc:= BMPIf.BitCount;
        NumS:=8 div Bc;
        RealyByte:=BMPIf.Width;
        Case Bc of
          8:Begin
              Mask:=$FF;
              While RealyByte mod 4 <> 0 do Inc (RealyByte);
            End;
          4:Begin
              Mask:=$0F;
              While RealyByte mod 8 <> 0 do Inc (RealyByte);
            End;
          1:Begin
              Mask:=1;
              While RealyByte mod 32 <> 0 do Inc (RealyByte);
            End;
        End;
    
        Dec (RealyByte);
    
        Repeat
          b:=Byte(P^);
          IncPoint (P,1);
          Inc (NumRead);
          If (NumRead=Result) then begin
    		 P:=Buffer;
             BlockRead (f, Buffer^, BufSize, Result);
             NumRead:=0
          End;
          If BMPIf.Compression = 0 then begin
             For k:=1 to NumS do begin
                 If i < ByteLine then
                 WritePixel (i, j, (b shr (8-Bc*k)) AND Mask);
                 If i < RealyByte then Inc (i)
                 Else begin
                      i:=0;
                      Dec(j)
                 End;
             End;
          End
        Until (j < VerLimit) OR (Port[$60]=1);
        Write (#7);
        Close (f);
        Freemem (Buffer,BufSize);
        { Repeat  Until KeyPressed;
        SetVideo (3,GraphOff) }
    End; {LoadBMP8bit}
    
    procedure   LoadBMP24bit (PosX, PosY :Integer; FileName :string; Delays :word);
    var
        Header: TBitmapHeader;
        Info: TBitmapInfoHeader;
        Size, Size_: Word;
    	f: file;
        Dl: array [0..5000] of TColor;
        x, y: Integer;
        Color: TColor;
    begin
        Assign (f, FileName);
        {$I-}
        Reset (f, 1);
        if IOResult <> 0 then Exit; 
        {$I+}
        
        BlockRead (f, Header, SizeOf (Header));
        BlockRead (f, Info, SizeOf (Info));
        
        if (Header.bfType <> 'BM') or (Info.BitCount <> 24) then
            begin
            Close (f);
            Exit;
            end;
        Size := Info.Width * 3;
        if Info.Width mod 2 <> 0 then Size := Size + 1;
        
        Seek (f, Header.bfOffBits);
        
        for y := Info.Height - 1 downto 0 do
            begin
            BlockRead (f, Dl, Size);
            for x := 0 to Info.Width - 1 do
    			begin
                PutPixel ( PosX + x, PosY + y, Dl [x].r, Dl [x].g, Dl [x].b );
                end;
    		{Crt.Delay (Delays);} {old: Delay (10;}
    		Crt.Delay (Delays); 
    		end;
    	Close (f);
    end; {LoadBMP24bit}
    (*-------------------------*)
    function GetVesaInfor :Boolean; assembler;
    asm
    	mov ax,Seg VesaInfor
    	mov es,ax
    	mov di,Offset VesaInfor
    	mov ax,4f00h
    	int 10h
    	cmp ax,4fh
    	je @@1
    	xor ax,ax
    	jmp @@2
    @@1:
    	mov ax,1
    @@2:
    end;
    {-------------------------------------------------------------------------}
    function GetModeInfor; assembler;
    asm
    	mov ax,Seg VesaModeInfor
    	mov es,ax
        mov di,Offset VesaModeInfor
        mov ax,4f01h
        mov cx,Mode
    	int 10h
        cmp ax,4fh           
        je @@1
        xor ax,ax
        jmp @@2    
    @@1:    
        mov ax,1
    @@2:
    end; 
    {-------------------------------------------------------------------------}
    function FindMode;
    var
        count :integer;
        i     :Word;
    begin 
        count:=0; 
        i := 0; 
        repeat
        Inc (i);
        GetModeInfor (VesaInfor.VideoModePtr^[i]);
        {writeln(VesaModeInfor.XResolution,' x ',VesaModeInfor.YResolution,'. ',VesaModeInfor.MemoryModel,' , '
        ,VesaInfor.VideoModePtr^[i]);}
        inc (count);
        if count = 24 then
        begin
         readln;
         count:=0;
        end;
    	until ((VesaModeInfor.XResolution = x) and
             (VesaModeInfor.YResolution = y) and
             (VesaModeInfor.MemoryModel = b)) or
             (VesaInfor.VideoModePtr^[i] = 65535);
        FindMode := VesaInfor.VideoModePtr^[i];
    end;
    {-------------------------------------------------------------------------}
    function InitGraph (x, y :Word; b :Byte) :boolean;
    var
        Mode :Word;
        Regs :Registers;
    begin
        Mode := FindMode (x, y, b);
        if Mode = 65535 then
            begin
            InitGraph := False;
            end
        else
            begin
            InitGraph := True;
            MaxX := VesaModeInfor.XResolution;
            MaxY := VesaModeInfor.YResolution;
            BitPerPixel := b;
            BytePerPixel := BitPerPixel div 8;
            if BitPerPixel = 15 then BytePerPixel := 2;
            BytePerLine := VesaModeInfor.BytesPerScanLine;
            DP := 32 div VesaModeInfor.WinGranularity;
            P := 0; PO := P;
    		asm
                mov ax,4F02h
                mov bx,Mode
                int 10h
            end;
            end;
    end;
    {-------------------------------------------------------------------------}
    procedure page; assembler;
    asm
        mov ax,P
        mov cl,DP
        shr ax,cl
        mov ax,4f05h
        mov bx,0
        mov dx,P
        int 10h
    end;
    {-------------------------------------------------------------------------}
    procedure Mem_;
    begin
        Mem [$A000:x_] := Mem [Seg_:Ofs_];
    end;
    {-------------------------------------------------------------------------}
    procedure RGB (transparent,r, g, b: LongInt; var Color: LongInt);
    begin
      Case BitPerPixel of    
        24:     Color := (r shl 16) or (g shl 8) or b;
    	32:     Color := (transparent shl 24) or (r shl 16) or (g shl 8) or b;
        16:     Color := (r shr 3 shl 11) or (g shr 2 shl 5) or b shr 3;
        15:     Color := (r shr 3 shl 10) or (g shr 3 shl 5) or b shr 3;
      end;
    end;
    {-------------------------------------------------------------------------}
    procedure Putpixel;
    label
        Lap, 
        Page1, 
        Page2;
    var
        Color :LongInt;
    begin
        RGB (150, r, g, b, Color);
        Seg_ := Seg (Color);
        Ofs_ := Ofs (Color);
    Asm
        Mov ax, x
        Mul BytePerPixel
        Mov x, ax
        Mov ax, y
        Mul BytePerPixel
        Mul MaxX
        Add ax, x
        Mov x_, ax
        Adc dx, 0
        Cmp dx, PO
        Je  Page1
        Mov P, dx
    	Mov bx, P
        Mov PO, bx
        Call Page
    Page1:
        Mov cx, BytePerPixel
    Lap:
        Call Mem_
        Inc Ofs_
        Add x_, 1
        Jae Page2
        Adc P, 0
        Mov bx, P
        Mov PO, bx
        Push cx
        Call Page
        Pop cx
    Page2:
    	Loop  Lap
    End;
    End;
    (*-------------------------*)
    function CloseGraph; assembler;
    asm
    	mov ax,0003h
    	int 10h
    end;
    (*-------------------------*)
    {procedure   Delayss (t :byte);}
    
    BEGIN
        GetVesaInfor;
    END.
    TEST:

    Code:
    {Hiện ảnh bitmap sử dụng thư viện BMP.TPU}
    {$M 32768,0,655360}
    {_______________________________________________________________} 
    USES 
        CRT, 
        BMP;
    TYPE
    	string8=string[8];
    VAR 
        bpp :byte; {=24 hoặc 32: Thông số khởi tạo chế độ màn hình đồ họa}
    	s: array [0..99] of string;
    CONST 
    	t :word =150; {delay của 1 dòng ảnh của 1 ảnh}
    	p :word =800; {delay giữa các ảnh liền nhau}
    	Width =640; {Kích thức ảnh}
    	Height =480;{Kích thức ảnh}
    {_______________________________________________________________}    
    procedure LoadId (fn :string8; ext :string8; num :byte) ;
    var
    	i:byte;
    	c:string;
    begin
    	for i:=0 to num do begin
    	str (i,c);  
    	s [i]:=fn+c+ext;  
    	end;	
    end;
    {_______________________________________________________________}
    procedure ShowImage (n :byte; t, p :word) ;
    var
    	i :byte;
    begin
    	for i:=0 to n do begin	
    	if KeyPressed then break;
    	BMP.LoadBMP24bit (0, 0, s [i], t); 
    	Crt.Delay (p);  
    	end;
    end;
    {_______________________________________________________________} 
    BEGIN	{DEMO}
    	bpp:= 24 {hoặc bpp:=32}
        BMP.InitGraph (Width, Height, bpp);	{Khởi tạo chế độ màn hình (Width, Height)= 640x480, 24 bit màu}
        (* 
        Chú ý: ảnh có size(Width, Height)= 640x480
        Các ảnh phải có tên giống nhau/ chỉ khác ở số thứ tự
        Ví dụ có 4 ảnh có tên:
            ANHSO0.bmp, ANHSO1.bmp, ANHSO2.bmp, ANHSO3.bmp
        Thì: 
        *)
    	LoadId ('ANHSO','.bmp', 4);
    	ShowImage (4,t,p);
        {-}
        Crt.Delay (2000);
    	BMP.CloseGraph;    
    END.	
    {_______________________________________________________________}
    ** Chú ý: trường hợp bpp:=24 mà không load được ảnh thì đổi bpp:=32
    ** Nếu chỉ load 1 ảnh vd như HoaCuc.bmp
    thì bỏ đoạn LoadId ('ANHSO','.bmp', 4); ShowImage (4,t,p);
    và Load ảnh trực tiếp:
    BMP.LoadBMP24bit (0, 0, 'HoaCuc.bmp', t);
    Crt.Delay (2000);
    BMP.CloseGraph;

    ---------------------------
    Chương trình:
    http://www.mediafire.com/download/ak...ih7/bmp24b.zip
    Được sửa bởi ada95 lúc 13:34 ngày 04-08-2016

  10. #8
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts

    7. Giải SUDOKU

    Tác giả: ???
    Code:
    USES crt;
    LABEL thoat;
    TYPE sn=1..9; s=SET OF sn;
         di=RECORD
          bi,ei,bj,ej: sn;
          END;
        ta= ARRAY[1..9,1..9] OF s;
        tb= ARRAY[1..9,1..9] OF INTEGER;
        tc= ARRAY[1..9,1..9] OF INTEGER;
        td= ARRAY[1..9,1..9] OF di;
        te= ARRAY[1..9,1..9] OF BOOLEAN;
    VAR px,py,n, unsolve: INTEGER;
        defaults:s;
        a: ta; b: tb; c:tc; d:td; e:te;
        solved, outnow: BOOLEAN;
        ch:char;
    
    {--------------------------------------------------------------------------------------}
    
    PROCEDURE solve(a:ta; b:tb; c:tc; d:td; e:te);
    VAR mini, minj, i, j, x, tgb: INTEGER; tga:s;
        ma:ta; mb:tb; mc:tc; me:te; mu: integer;
        found: boolean;
        {-------------------------------------------------------------------------}
    
        function det(i,j: integer):sn;
        var k:integer;
        begin
         for k:=1 to 9 do if k in a[i,j] then begin det:=k; break; end;
        end;
    
        {--------------------------------------------------------------------------------}
    
        {--------------------------------------------------------------------------------}
    
        PROCEDURE canquet(i,j: INTEGER);
        VAR k,m: INTEGER;
        BEGIN
            e[i,j]:=TRUE;
            c[i,j]:=det(i,j);
            FOR k:=1 TO 9 DO IF (c[i,j] IN a[k,j]) AND (k<>i) THEN BEGIN a[k,j]:=a[k,j]-[c[i,j]]; dec(b[k,j]); END;
            FOR m:=1 TO 9 DO IF (c[i,j] IN a[i,m]) AND (m<>j) THEN BEGIN a[i,m]:=a[i,m]-[c[i,j]]; dec(b[i,m]); END;
            FOR k:=d[i,j].bi TO d[i,j].ei DO FOR m:=d[i,j].bj TO d[i,j].ej DO
            IF (c[i,j] IN a[k,m]) AND (k<>i) AND (m<>j) THEN BEGIN a[k,m]:=a[k,m]-[c[i,j]]; dec(b[k,m]); END;
        END;
    
        {--------------------------------------------------------------------------------}
    
        PROCEDURE findmin;
        VAR i,j,min:INTEGER;
        BEGIN
            min:=10;
            FOR i:=1 TO 9 DO
            FOR j:=1 TO 9 DO
            IF (b[i,j]<min) AND (e[i,j]=FALSE) THEN
             BEGIN mini:=i; minj:=j; min:=b[i,j]; END;
        END;
    
        {---------------------------------------------------------------------------------}
    
        BEGIN
        IF not(outnow) THEN
        IF unsolve=0 THEN
         BEGIN
            solved:=true;
            gotoxy(1,11);
            textcolor(white);
            Write('Press Enter to see next available Solution or ESC to escape');
            textcolor(yellow);
            FOR i:=1 TO 9 DO FOR j:=1 TO 9 DO
            BEGIN
                gotoxy(3*j-1,i);
                write(c[i,j]);
            END;
            gotoxy(25,12);
            repeat n:=ord(readkey) until (n=13) or (n=27);
            if n=27 then outnow:=true;
         END
        ELSE
         BEGIN
          findmin;
          FOR x:=1 TO 9 DO IF x IN a[mini,minj] THEN
          BEGIN
            ma:=a; mb:=b; mc:=c; me:=e;
            mu:=unsolve;
            a[mini,minj]:=[x];
            b[mini,minj]:=1;
            c[mini,minj]:=x;
            repeat
            found:=false;
            FOR i:=1 TO 9 DO
            FOR j:=1 TO 9 DO
            IF (b[i,j]=1) and (e[i,j]=false) THEN begin found:=true; dec(unsolve); canquet(i,j); end;
            until found=false;
            solve(a,b,c,d,e);
            a:=ma; b:=mb; c:=mc; e:=me;
            unsolve:=mu;
          END;
         END;
        END;
    
    {------------------------------------------------------------------------------------}
    
    PROCEDURE init;
    VAR i,j: INTEGER;
    BEGIN
    clrscr;
    solved:=false; outnow:=false;
    defaults:=[1,2,3,4,5,6,7,8,9];
    FOR i:=1 TO 9 DO FOR j:=1 TO 9 DO
     BEGIN a[i,j]:=defaults;
           b[i,j]:=9;
           c[i,j]:=0;
           e[i,j]:=FALSE;
           IF i<4 THEN BEGIN d[i,j].bi:=1; d[i,j].ei:=3 END ELSE
           IF i>6 THEN BEGIN d[i,j].bi:=7; d[i,j].ei:=9 END ELSE
                       BEGIN d[i,j].bi:=4; d[i,j].ei:=6 END;
           IF j<4 THEN BEGIN d[i,j].bj:=1; d[i,j].ej:=3 END ELSE
           IF j>6 THEN BEGIN d[i,j].bj:=7; d[i,j].ej:=9 END ELSE
                       BEGIN d[i,j].bj:=4; d[i,j].ej:=6 END;
     END;
    FOR i:=1 TO 9 DO
     BEGIN
     FOR j:=1 TO 9 DO
      BEGIN
       IF ((i<4) OR (i>6)) AND ((j<4) OR (j>6)) THEN textcolor(lightblue)
       ELSE IF ((i-4)*(6-i)>=0) AND ((j-4)*(6-j)>=0) THEN textcolor(red)
       ELSE textcolor(green);
       write('[ ]');
      END;
     writeln;
     END;
    writeln; textcolor(white);
    gotoxy(30,5);
    write('     <-- Step 1: Enter clues');
    gotoxy(1,11);
    writeln('Step 2: ');
    writeln('Move your pointer here [ ] then hit Space bar for the Solution');
    unsolve:=81;
    END;
    
    {--------------------------------------------------------------------------------}
    
    BEGIN
    repeat
    init;
    gotoxy(2,1); px:=2; py:=1;
    REPEAT
     n:=ord(readkey);
     IF py<10 THEN
     BEGIN
      IF n=75 THEN px:=px-3;
      IF n=80 THEN py:=py+1;
      IF n=77 THEN px:=px+3;
      IF n=72 THEN py:=py-1;
      IF (px<0) OR (py<1) OR (px>26) OR (py>9) THEN BEGIN px:=25; py:=12; END;
      gotoxy(px, py);
      IF (49-n)*(n-57)>=0 THEN
       BEGIN
        write(n-48); gotoxy(wherex-1,wherey);
        a[py,(px+1)DIV 3]:=[n-48];
        c[py,(px+1)DIV 3]:= n-48 ;
        b[py,(px+1)DIV 3]:=1;
       END;
      IF (n=32) or (n=8) or (n=83) THEN
       BEGIN
        write(' '); gotoxy(wherex-1,wherey);
        a[py,(px+1)DIV 3]:=defaults;
        c[py,(px+1)DIV 3]:=0;
        b[py,(px+1)DIV 3]:=9;
       END;
     END
     ELSE IF n=32 THEN begin solve(a,b,c,d,e); break; end
     ELSE BEGIN gotoxy(2,1); px:=2; py:=1; n:=ord(readkey); END;
    UNTIL unsolve=0;
    {-------------------}
    textcolor(white);
    Gotoxy(1,11);
    thoat: If not(solved) then Writeln('Invalid Input !                                    ')
                   else Writeln('                                                             ');
    Writeln('Refresh (Y/N)?                                                                ');
    Gotoxy(15,12); ch:=readkey;
    if upcase(ch)='N' then break
    until false;
    {---------------------}
    END.
    ** Khác: Trực tiếp bảng trong chương trình: https://rosettacode.org/wiki/Sudoku#Pascal
    Được sửa bởi ada95 lúc 14:49 ngày 16-08-2016

  11. #9
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts

    Hiện ảnh đơn sắc (=1 bit màu)

    Được sửa bởi ada95 lúc 14:45 ngày 16-08-2016

  12. #10
    Tham gia
    13-08-2012
    Location
    Vĩnh Cửu, Đồng Nai
    Bài viết
    78
    Like
    7
    Thanked 9 Times in 8 Posts
    Phương trình tham số
    Unus Pro Omnibus, Omnes Pro Uno

Bookmarks

Quy định

  • Bạn không thể tạo chủ đề mới
  • Bạn không thể trả lời bài viết
  • Bạn không thể gửi file đính kèm
  • Bạn không thể sửa bài viết của mình
  •