设为首页收藏本站
B. Malaysia手机版

佳礼资讯网

 找回密码
 注册

ADVERTISEMENT

佳礼资讯网»论坛 › 电脑手机 › 系统，软件 › 谁要.PAS源代码？
返回列表 发新帖
查看: 1208|回复: 19

谁要.PAS源代码？

[复制链接]
FlierMate.
发表于 4-3-2011 07:32 AM | 显示全部楼层 |阅读模式
本帖最后由 FlierMate. 于 4-3-2011 01:51 PM 编辑

我有一些十多年前利用Turbo Pascal 7开发的程序现在找回源代码，想与感兴趣人士分享。

请回复，同时告知你要的模块。另外有适合学院生参考的数据库程序。


大概有这些，请看目录。（下载点我将另外提供）
回复

使用道具 举报


ADVERTISEMENT

FlierMate.
 楼主| 发表于 4-3-2011 06:19 PM | 显示全部楼层
这里有一个示例：

其实文本文件如果没有使用Extended ASCII，是可以Strip掉第8个比特(Bit)的，变相另外一种压缩原理。------概念来自书本，我只是编写出来而已：


压缩：

  1. {
  2.   File Packer
  3.   Programmed by Boo Khan Ming

  5.   E-mail: bookm@tm.net.my
  6.   WWW:    http://www.geocities.com/SiliconValley/Horizon/3409/

  8.   This program was initially written in 1995.8.21
  9.   Revised in 1999.6.20

  11.   --------------------------------------------------------------------------

  13.   This program compresses plain text file only, by stripping off the highest
  14.   unused bit, that is, 8-bit character is truncated to 7-bit character,
  15.   since the highest bit is unused for plain text (ASCII below 128).

  17.   During the packing, every 8 bytes is compact to 7 bytes, as the highest
  18.   unused bit of every 7 bytes exactly fit another 7-bit character.

  20.   This method of compression always saves 12.5% (1/8).
  21.   Works on plain text file only.
  22. }

  24. var
  25.   OutputFileName,InputFileName:string;
  26.   InputFile,OutputFile:file of byte;
  27.   InputCode,OutputCode:byte;
  28.   Done:boolean;
  29.   Counter:byte;

  31. begin
  32.   WriteLn('File Packer');
  33.   WriteLn('Developed by Boo Khan Ming');
  34.   WriteLn;

  36.   if ParamCount<>2 then
  37.   begin
  38.     WriteLn('Usage:  PACK <input filename> <output filename>');
  39.     Halt(255);
  40.   end;

  42.   InputFileName:=ParamStr(1);
  43.   OutputFileName:=ParamStr(2);

  45.   {$I-}
  46.   Assign(InputFile,InputFileName);
  47.   Reset(InputFile);
  48.   {$I+}
  49.   if IOResult<>0 then
  50.   begin
  51.     WriteLn('Unable to open input file.');
  52.     Halt(1);
  53.   end;

  55.   {$I-}
  56.   Assign(OutputFile,OutputFileName);
  57.   Rewrite(OutputFile);
  58.   {$I+}
  59.   if IOResult<>0 then
  60.   begin
  61.     WriteLn('Unable to create output file.');
  62.     Halt(2);
  63.   end;

  65.   Done:=False;

  67.   repeat
  68.     Read(InputFile,InputCode);

  70.     if EOF(InputFile) then
  71.       Done:=True
  72.     else
  73.     begin
  74.       { Shift off leftmost unused bit }
  75.       InputCode:=InputCode shl 1;

  77.       for Counter:=0 to 6 do
  78.       begin
  79.         if EOF(InputFile) then
  80.         begin
  81.           OutputCode:=0;
  82.           Done:=True;
  83.         end
  84.         else
  85.         begin
  86.           Read(InputFile,OutputCode);

  88.           { Turn off top bit }
  89.           OutputCode:=OutputCode and 127;

  91.           { Pack bit }
  92.           OutputCode:=OutputCode or ((InputCode shl Counter) and 128);

  94.           Write(OutputFile,OutputCode);
  95.         end;
  96.       end;
  97.     end;
  98.   until Done;

  100.   Close(InputFile);
  101.   Close(OutputFile);
  102. end.
复制代码



解压缩：

  1. {
  2.   File Depacker
  3.   Programmed by Boo Khan Ming

  5.   E-mail: bookm@tm.net.my
  6.   WWW:    http://www.geocities.com/SiliconValley/Horizon/3409/

  8.   This program was initially written in 1995.8.21
  9.   Revised in 1999.6.20

  11.   --------------------------------------------------------------------------

  13.   This program compresses plain text file only, by stripping off the highest
  14.   unused bit, that is, 8-bit character is truncated to 7-bit character,
  15.   since the highest bit is unused for plain text (ASCII below 128).

  17.   During the packing, every 8 bytes is compact to 7 bytes, as the highest
  18.   unused bit of every 7 bytes exactly fit another 7-bit character.

  20.   This method of compression always saves 12.5% (1/8).
  21.   Works on plain text file only.
  22. }

  24. var
  25.   OutputFileName,InputFileName:string;
  26.   InputFile,OutputFile:file of byte;
  27.   InputCode,OutputCode:byte;
  28.   Done:boolean;
  29.   Counter:byte;
  30.   ByteArray:array [1..7] of byte;

  32. begin
  33.   WriteLn('File Depacker');
  34.   WriteLn('Developed by Boo Khan Ming');
  35.   WriteLn;

  37.   if ParamCount<>2 then
  38.   begin
  39.     WriteLn('Usage:  DEPACK <input filename> <output filename>');
  40.     Halt(255);
  41.   end;

  43.   InputFileName:=ParamStr(1);
  44.   OutputFileName:=ParamStr(2);

  46.   {$I-}
  47.   Assign(InputFile,InputFileName);
  48.   Reset(InputFile);
  49.   {$I+}
  50.   if IOResult<>0 then
  51.   begin
  52.     WriteLn('Unable to open input file.');
  53.     Halt(1);
  54.   end;

  56.   {$I-}
  57.   Assign(OutputFile,OutputFileName);
  58.   Rewrite(OutputFile);
  59.   {$I+}
  60.   if IOResult<>0 then
  61.   begin
  62.     WriteLn('Unable to create output file.');
  63.     Halt(2);
  64.   end;

  66.   Done:=False;

  68.   repeat
  69.     InputCode:=0;

  71.     for Counter:=1 to 7 do
  72.     begin
  73.       if EOF(InputFile) then
  74.         Done:=True
  75.       else
  76.       begin
  77.         Read(InputFile,OutputCode);

  79.         { Turn off top bit }
  80.         ByteArray[Counter]:=OutputCode and 127;

  82.         { Clear lower bit and depack bit }
  83.         OutputCode:=(OutputCode and 128) shr Counter;

  85.         { Build up the 8th byte }
  86.         InputCode:=InputCode or OutputCode;
  87.       end;
  88.     end;

  90.     Write(OutputFile,InputCode);

  92.     for Counter:=1 to 7 do
  93.       Write(OutputFile,ByteArray[Counter]);
  94.   until Done;

  96.   Close(InputFile);
  97.   Close(OutputFile);
  98. end.
复制代码
回复

使用道具 举报

FlierMate.
 楼主| 发表于 4-3-2011 06:29 PM | 显示全部楼层
这是另外一个很原始的音效卡‘完全攻略’。当年用RM10买了Creative Labs Sound Blaster 16的Technical Reference，结果就用Turbo Pascal编写出一个模块(.TPU)。此原理也可以将你的SB16（当然现在怎么有人用）变成Digital Signal Analyser（实验室用着的咧），因为Sound Card本身就有DAC(Digital-Analog Converter)。

  1. unit Sound;
  2. {
  3.   Sound Service Unit
  4.   Revision 2 (1997-1998)
  5.   Developed by Boo Khan Ming

  7.   Provide direct access to Sound Blaster compatible sound card.

  9.   Featuring hardware diagnostic, full control of mixer settings and various
  10.   recording preferences.

  12.   Support sample playing and recording.
  13. }

  15. interface

  17. const
  18.   DirectSoundFormatID='DLS';

  20.   Mic=0;
  21.   CD=1;
  22.   Line=3;

  24. type
  25.   DirectSoundFormatType=record
  26.     ID:string[3];
  27.     Version:word;
  28.     Description:string;
  29.     HardwareRevision:word;
  30.     Frequency:word;
  31.     MasterVolume:word;
  32.     VoiceVolume:word;
  33.   end;

  35. var
  36.   MasterSignal,SlaveSignal:boolean;
  37.   VoicePointer,VoiceLength:longint;
  38.   RecordLength:word;
  39.   SoundCardBasePort:word;
  40.   DirectSoundFormat:DirectSoundFormatType;

  42. function AutoDetectSoundCard(var BasePort:word):boolean;
  43. procedure ResetDSP;
  44. procedure OutputDataDSP(Data:byte);
  45. function InputDataDSP:byte;
  46. procedure CheckDSPVersion(var Major,Minor:byte);
  47. function CheckSoundCardType:string;
  48. procedure NewTimerHandler; interrupt;
  49. procedure ChangeTimerFrequency(Frequency:word);
  50. procedure StartTimerHandler(NewVector:pointer;Frequency:word);
  51. procedure RestoreTimerHandler;

  53. procedure ResetVolumeSettings;
  54. procedure ChangeMasterVolume(Left,Right:byte);
  55. procedure ChangeVoiceVolume(Left,Right:byte);
  56. procedure ChangeMIDIVolume(Left,Right:byte);
  57. procedure ChangeCDVolume(Left,Right:byte);
  58. procedure ChangeLineVolume(Left,Right:byte);
  59. procedure ChangeMicVolume(Balance:byte);
  60. procedure CheckMasterVolume(var Left,Right:byte);
  61. procedure CheckVoiceVolume(var Left,Right:byte);
  62. procedure CheckMIDIVolume(var Left,Right:byte);
  63. procedure CheckCDVolume(var Left,Right:byte);
  64. procedure CheckLineVolume(var Left,Right:byte);
  65. procedure CheckMicVolume(var Balance:byte);

  67. procedure SelectVoiceInput(Source:byte);
  68. procedure EnableInputFilter;
  69. procedure DisableInputFilter;
  70. procedure EnableOutputFilter;
  71. procedure DisableOutputFilter;
  72. procedure SelectStereoOutput;
  73. procedure SelectMonoOutput;
  74. procedure SelectHighPassFilter;
  75. procedure SelectLowPassFilter;
  76. procedure ChangeSamplingRate(Rate:longint);

  78. function PrepareRecordVoice:boolean;
  79. procedure ShutRecordVoice;
  80. procedure RecordVoice;
  81. procedure PlayVoice;
  82. function SaveVoice(FileName:string;Description:string):boolean;
  83. function OpenVoice(FileName:string;Manual:boolean;var Description:string):boolean;

  85. implementation

  87. uses DOS,Swap,Mouse,Error;

  89. const
  90.   TemporaryVector=100;

  92.   ResetRegister=$06;
  93.   ReadDataRegister=$0a;
  94.   WriteCommandRegister=$0c;
  95.   WriteBufferRegister=$0c;
  96.   DataAvailableRegister=$0e;

  98.   ChannelRegister=$02;
  99.   MasterRegister=$22;
  100.   VoiceRegister=$04;
  101.   MIDIRegister=$26;
  102.   CDRegister=$28;
  103.   LineRegister=$2e;
  104.   MicRegister=$0a;

  106. var
  107.   Counter:word;
  108.   VoiceData:byte;
  109.   DirectSoundFile:file of byte;

  111. function AutoDetectSoundCard(var BasePort:word):boolean;
  112. const
  113.   RetryTime1=10;
  114.   RetryTime2=100;

  116. var
  117.   Counter1,Counter2:word;
  118.   Found:boolean;

  120. begin
  121.   BasePort:=$210;
  122.   Found:=False;
  123.   Counter1:=RetryTime1;

  125.   while (BasePort<=$260) and (not Found) do
  126.   begin
  127.     Port[BasePort+ResetRegister]:=1;
  128.     Port[BasePort+ResetRegister]:=0;

  130.     while (Counter2>RetryTime2) and (Port[BasePort+DataAvailableRegister]<128) do
  131.       Dec(Counter2);

  133.     if (Counter2=0) or (Port[BasePort+$a]<>$aa) then
  134.     begin
  135.       Dec(Counter1);

  137.       if Counter1=0 then
  138.       begin
  139.         Counter1:=RetryTime1;
  140.         BasePort:=BasePort+$10;
  141.       end;
  142.     end
  143.     else
  144.     begin
  145.       Found:=True;
  146.       SoundCardBasePort:=BasePort;
  147.     end;
  148.   end;

  150.   AutoDetectSoundCard:=Found;
  151. end;

  153. procedure ResetDSP;
  154. begin
  155.   Port[SoundCardBasePort+ResetRegister]:=1;
  156.   Port[SoundCardBasePort+ResetRegister]:=0;

  158.   while (Port[SoundCardBasePort+DataAvailableRegister] and 128)=0 do;
  159.   while not (Port[SoundCardBasePort+ReadDataRegister]=$aa) do;
  160. end;

  162. procedure OutputDataDSP(Data:byte);
  163. begin
  164.   while (Port[SoundCardBasePort+WriteBufferRegister] and 128)<>0 do;
  165.   Port[SoundCardBasePort+WriteCommandRegister]:=Data;
  166. end;

  168. function InputDataDSP:byte;
  169. begin
  170.   while (Port[SoundCardBasePort+DataAvailableRegister] and 128)=0 do;
  171.   InputDataDSP:=Port[SoundCardBasePort+ReadDataRegister];
  172. end;

  174. procedure CheckDSPVersion(var Major,Minor:byte);
  175. begin
  176.   OutputDataDSP($e1);
  177.   Major:=InputDataDSP;
  178.   Minor:=InputDataDSP;
  179. end;

  181. function CheckSoundCardType:string;
  182. var
  183.   Major,Minor:byte;

  185. begin
  186.   CheckDSPVersion(Major,Minor);

  188.   case Major of
  189.     1:CheckSoundCardType:='Sound Blaster';
  190.     2:CheckSoundCardType:='Sound Blaster Pro';
  191.     else
  192.       CheckSoundCardType:='Sound Blaster 16';
  193.   end;
  194. end;

  196. procedure ChangeTimerFrequency(Frequency:word);
  197. var
  198.   Counter:word;

  200. begin
  201.   Inline($fa);
  202.   Counter:=1193180 div Frequency;

  204.   Port[$43]:=$36;
  205.   Port[$40]:=Lo(Counter);
  206.   Port[$40]:=Hi(Counter);

  208.   Inline($fb);

  210.   DirectSoundFormat.Frequency:=Frequency;
  211. end;

  213. procedure StartTimerHandler(NewVector:pointer;Frequency:word);
  214. var
  215.   OldVector:pointer;

  217. begin
  218.   Inline($fa);

  220.   GetIntVec(8,OldVector);
  221.   SetIntVec(TemporaryVector,OldVector);
  222.   SetIntVec(8,NewVector);

  224.   ChangeTimerFrequency(Frequency);

  226.   Inline($fb);
  227. end;

  229. procedure RestoreTimerHandler;
  230. var
  231.   OldVector:pointer;

  233. begin
  234.   Inline($fa);

  236.   Port[$43]:=$36;
  237.   Port[$40]:=0;
  238.   Port[$40]:=0;

  240.   GetIntVec(TemporaryVector,OldVector);
  241.   SetIntVec(8,OldVector);

  243.   Inline($fb);
  244. end;

  246. procedure NewTimerHandler; {interrupt;}
  247. var
  248.   Register:Registers;

  250. begin
  251.   Dec(Counter);
  252.   if Counter=0 then
  253.   begin
  254.     Intr(TemporaryVector,Register);
  255.     Counter:=100 div 18;
  256.   end
  257.   else
  258.     Port[$20]:=$20;

  260.   MasterSignal:=not MasterSignal;
  261. end;

  263. procedure ResetVolumeSettings;
  264. begin
  265.   Port[SoundCardBasePort+$04]:=0;
  266.   Port[SoundCardBasePort+$05]:=0;
  267. end;

  269. procedure ChangeVolumeSettings(Left,Right:byte);
  270. begin
  271.   Port[SoundCardBasePort+$04]:=ChannelRegister;
  272.   Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
  273. end;

  275. procedure ChangeMasterVolume(Left,Right:byte);
  276. begin
  277.   Port[SoundCardBasePort+$04]:=MasterRegister;
  278.   Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
  279. end;

  281. procedure ChangeVoiceVolume(Left,Right:byte);
  282. begin
  283.   Port[SoundCardBasePort+$04]:=VoiceRegister;
  284.   Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
  285. end;

  287. procedure ChangeMIDIVolume(Left,Right:byte);
  288. begin
  289.   Port[SoundCardBasePort+$04]:=MIDIRegister;
  290.   Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
  291. end;

  293. procedure ChangeCDVolume(Left,Right:byte);
  294. begin
  295.   Port[SoundCardBasePort+$04]:=CDRegister;
  296.   Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
  297. end;

  299. procedure ChangeLineVolume(Left,Right:byte);
  300. begin
  301.   Port[SoundCardBasePort+$04]:=LineRegister;
  302.   Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
  303. end;

  305. procedure ChangeMicVolume(Balance:byte);
  306. begin
  307.   Port[SoundCardBasePort+$04]:=MicRegister;
  308.   Port[SoundCardBasePort+$05]:=Balance;
  309. end;

  311. procedure CheckMasterVolume(var Left,Right:byte);
  312. begin
  313.   Port[SoundCardBasePort+$04]:=MasterRegister;
  314.   Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
  315.   Right:=Port[SoundCardBasePort+$05] and $0f;
  316. end;

  318. procedure CheckVoiceVolume(var Left,Right:byte);
  319. begin
  320.   Port[SoundCardBasePort+$04]:=VoiceRegister;
  321.   Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
  322.   Right:=Port[SoundCardBasePort+$05] and $0f;
  323. end;

  325. procedure CheckMIDIVolume(var Left,Right:byte);
  326. begin
  327.   Port[SoundCardBasePort+$04]:=MIDIRegister;
  328.   Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
  329.   Right:=Port[SoundCardBasePort+$05] and $0f;
  330. end;

  332. procedure CheckCDVolume(var Left,Right:byte);
  333. begin
  334.   Port[SoundCardBasePort+$04]:=CDRegister;
  335.   Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
  336.   Right:=Port[SoundCardBasePort+$05] and $0f;
  337. end;

  339. procedure CheckLineVolume(var Left,Right:byte);
  340. begin
  341.   Port[SoundCardBasePort+$04]:=LineRegister;
  342.   Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
  343.   Right:=Port[SoundCardBasePort+$05] and $0f;
  344. end;

  346. procedure CheckMicVolume(var Balance:byte);
  347. begin
  348.   Port[SoundCardBasePort+$04]:=MicRegister;
  349.   Balance:=Port[SoundCardBasePort+$05];
  350. end;

  352. procedure SelectVoiceInput(Source:byte);
  353. begin
  354.   Port[SoundCardBasePort+$04]:=$0c;
  355.   Port[SoundCardBasePort+$05]:=(Port[SoundCardBasePort+$05] and (not 7)) or ((Source shl 1) and 7);
  356. end;

  358. procedure EnableInputFilter;
  359. begin
  360.   Port[SoundCardBasePort+$04]:=$0c;
  361.   Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or 32;
  362. end;

  364. procedure DisableInputFilter;
  365. begin
  366.   Port[SoundCardBasePort+$04]:=$0c;
  367.   Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or (not 32);
  368. end;

  370. procedure EnableOutputFilter;
  371. begin
  372.   Port[SoundCardBasePort+$04]:=$0e;
  373.   Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or 64;
  374. end;

  376. procedure DisableOutputFilter;
  377. begin
  378.   Port[SoundCardBasePort+$04]:=$0e;
  379.   Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or (not 64);
  380. end;
复制代码



待续……。
回复

使用道具 举报

FlierMate.
 楼主| 发表于 4-3-2011 06:29 PM | 显示全部楼层

……接上

  1. procedure SelectStereoOutput;
  2. begin
  3.   Port[SoundCardBasePort+$04]:=$0e;
  4.   Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or 2;
  5. end;

  7. procedure SelectMonoOutput;
  8. begin
  9.   Port[SoundCardBasePort+$04]:=$0e;
  10.   Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or (not 2);
  11. end;

  13. procedure SelectHighPassFilter;
  14. begin
  15.   Port[SoundCardBasePort+$04]:=$0c;
  16.   Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or 8;
  17. end;

  19. procedure SelectLowPassFilter;
  20. begin
  21.   Port[SoundCardBasePort+$04]:=$0c;
  22.   Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or (not 8);
  23. end;

  25. procedure ChangeSamplingRate(Rate:longint);
  26. begin
  27.   Port[SoundCardBasePort+WriteBufferRegister]:=$40;
  28.   repeat until Port[SoundCardBasePort+WriteBufferRegister]<128;
  29.   Port[SoundCardBasePort+WriteBufferRegister]:=Round(256-1000000/Rate);
  30. end;

  32. function PrepareRecordVoice:boolean;
  33. begin
  34.   DefineDefaultSwapFile('SOUND.SWP');

  36.   if EstablishVirtualMemory(ByteType,60*4*1024*RecordLength,1)<>0 then
  37.   begin
  38.     PrepareRecordVoice:=False;
  39.     Exit;
  40.   end;

  42.   PrepareRecordVoice:=True;
  43. end;

  45. procedure ShutRecordVoice;
  46. begin
  47.   DisposeVirtualMemory;

  49.   VoicePointer:=0;
  50.   VoiceLength:=0;
  51. end;

  53. procedure RecordVoice;
  54. begin
  55.   VoicePointer:=0;

  57.   repeat
  58.     Port[SoundCardBasePort+WriteBufferRegister]:=$20;
  59.     repeat until Port[SoundCardBasePort+DataAvailableRegister]>=128;

  61.     EnterDataByte(0,VoicePointer,Port[SoundCardBasePort+ReadDataRegister]);
  62.     Inc(VoicePointer);

  64.     repeat until SlaveSignal=not MasterSignal;
  65.     SlaveSignal:=MasterSignal;

  67.     if GetMouseEvent<>0 then
  68.       Break;
  69.   until VoicePointer>=(60*4*1024*RecordLength);

  71.   VoiceLength:=VoicePointer;
  72.   repeat until GetMouseEvent=0;
  73. end;

  75. procedure PlayVoice;
  76. begin
  77.   VoicePointer:=0;

  79.   repeat
  80.     Port[SoundCardBasePort+WriteBufferRegister]:=$10;
  81.     repeat until Port[SoundCardBasePort+WriteBufferRegister]<128;

  83.     Port[SoundCardBasePort+WriteBufferRegister]:=EnquireDataByte(0,VoicePointer);
  84.     Inc(VoicePointer);

  86.     repeat until SlaveSignal=not MasterSignal;
  87.     SlaveSignal:=MasterSignal;

  89.     if GetMouseEvent<>0 then
  90.       Break;
  91.   until VoicePointer>=VoiceLength;

  93.   repeat until GetMouseEvent=0;
  94. end;

  96. function SaveVoice(FileName:string;Description:string):boolean;
  97. var
  98.   Major,Minor:byte;
  99.   Left,Right:byte;
  100.   Counter:word;

  102. begin
  103.   SaveVoice:=False;
  104.   VoicePointer:=0;

  106.   {$I-}
  107.   Assign(DirectSoundFile,FileName);
  108.   Rewrite(DirectSoundFile);
  109.   {$I+}
  110.   if IOResult<>0 then
  111.     Exit;

  113.   CheckDSPVersion(Major,Minor);

  115.   DirectSoundFormat.ID:=DirectSoundFormatID;
  116.   DirectSoundFormat.Version:=(1 shl 8) or (0);
  117.   DirectSoundFormat.HardwareRevision:=(Major shl 8) or (Minor);
  118.   DirectSoundFormat.Description:=Description;

  120.   CheckMasterVolume(Left,Right);
  121.   DirectSoundFormat.MasterVolume:=(Left shl 8) or Right;
  122.   CheckVoiceVolume(Left,Right);
  123.   DirectSoundFormat.VoiceVolume:=(Left shl 8) or Right;

  125.   {$I-}
  126.   for Counter:=1 to 3 do
  127.   begin
  128.     VoiceData:=Ord(DirectSoundFormat.ID[Counter]);
  129.     Write(DirectSoundFile,VoiceData);
  130.   end;

  132.   VoiceData:=Hi(DirectSoundFormat.Version);
  133.   Write(DirectSoundFile,VoiceData);
  134.   VoiceData:=Lo(DirectSoundFormat.Version);
  135.   Write(DirectSoundFile,VoiceData);

  137.   for Counter:=1 to 255 do
  138.   begin
  139.     VoiceData:=Ord(DirectSoundFormat.Description[Counter]);
  140.     Write(DirectSoundFile,VoiceData);
  141.   end;

  143.   VoiceData:=Hi(DirectSoundFormat.HardwareRevision);
  144.   Write(DirectSoundFile,VoiceData);
  145.   VoiceData:=Lo(DirectSoundFormat.HardwareRevision);
  146.   Write(DirectSoundFile,VoiceData);

  148.   VoiceData:=Hi(DirectSoundFormat.Frequency);
  149.   Write(DirectSoundFile,VoiceData);
  150.   VoiceData:=Lo(DirectSoundFormat.Frequency);
  151.   Write(DirectSoundFile,VoiceData);

  153.   VoiceData:=Hi(DirectSoundFormat.MasterVolume);
  154.   Write(DirectSoundFile,VoiceData);
  155.   VoiceData:=Lo(DirectSoundFormat.MasterVolume);
  156.   Write(DirectSoundFile,VoiceData);

  158.   VoiceData:=Hi(DirectSoundFormat.VoiceVolume);
  159.   Write(DirectSoundFile,VoiceData);
  160.   VoiceData:=Lo(DirectSoundFormat.VoiceVolume);
  161.   Write(DirectSoundFile,VoiceData);

  163.   repeat
  164.     VoiceData:=EnquireDataByte(0,VoicePointer);
  165.     Inc(VoicePointer);

  167.     Write(DirectSoundFile,VoiceData);
  168.   until VoicePointer>=VoiceLength;

  170.   Close(DirectSoundFile);
  171.   {$I+}
  172.   if IOResult<>0 then
  173.     Exit;

  175.   SaveVoice:=True;
  176. end;

  178. function OpenVoice(FileName:string;Manual:boolean;var Description:string):boolean;
  179. var
  180.   Counter:word;

  182. begin
  183.   OpenVoice:=False;
  184.   VoicePointer:=0;

  186.   {$I-}
  187.   Assign(DirectSoundFile,FileName);
  188.   Reset(DirectSoundFile);
  189.   {$I+}
  190.   if IOResult<>0 then
  191.     Exit;

  193.   {$I-}
  194.   for Counter:=1 to 3 do
  195.   begin
  196.     Read(DirectSoundFile,VoiceData);
  197.     DirectSoundFormat.ID:=DirectSoundFormat.ID+Chr(VoiceData);
  198.   end;

  200.   if DirectSoundFormat.ID<>DirectSoundFormatID then
  201.     Exit;

  203.   Read(DirectSoundFile,VoiceData);
  204.   DirectSoundFormat.Version:=VoiceData shl 8;
  205.   Read(DirectSoundFile,VoiceData);
  206.   DirectSoundFormat.Version:=DirectSoundFormat.Version or VoiceData;

  208.   Description:='';

  210.   for Counter:=1 to 255 do
  211.   begin
  212.     Read(DirectSoundFile,VoiceData);
  213.     Description:=Description+Chr(VoiceData);
  214.   end;

  216.   Read(DirectSoundFile,VoiceData);
  217.   DirectSoundFormat.HardwareRevision:=VoiceData shl 8;
  218.   Read(DirectSoundFile,VoiceData);
  219.   DirectSoundFormat.HardwareRevision:=DirectSoundFormat.Version or VoiceData;

  221.   Read(DirectSoundFile,VoiceData);
  222.   DirectSoundFormat.Frequency:=VoiceData shl 8;
  223.   Read(DirectSoundFile,VoiceData);
  224.   DirectSoundFormat.Frequency:=DirectSoundFormat.Version or VoiceData;

  226.   Read(DirectSoundFile,VoiceData);
  227.   DirectSoundFormat.MasterVolume:=VoiceData shl 8;
  228.   Read(DirectSoundFile,VoiceData);
  229.   DirectSoundFormat.MasterVolume:=DirectSoundFormat.Version or VoiceData;

  231.   Read(DirectSoundFile,VoiceData);
  232.   DirectSoundFormat.VoiceVolume:=VoiceData shl 8;
  233.   Read(DirectSoundFile,VoiceData);
  234.   DirectSoundFormat.VoiceVolume:=DirectSoundFormat.Version or VoiceData;

  236.   if not Manual then
  237.   begin
  238.     ChangeTimerFrequency(DirectSoundFormat.Frequency);
  239.     {if Hi(DirectSoundFormat.HardwareRevision)>=2 then
  240.     begin
  241.       ChangeMasterVolume(Hi(DirectSoundFormat.MasterVolume),Lo(DirectSoundFormat.MasterVolume));
  242.       ChangeVoiceVolume(Hi(DirectSoundFormat.VoiceVolume),Lo(DirectSoundFormat.VoiceVolume));
  243.     end;}
  244.   end;

  246.   repeat
  247.     Read(DirectSoundFile,VoiceData);

  249.     EnterDataByte(0,VoicePointer,VoiceData);
  250.     Inc(VoicePointer);
  251.   until (VoicePointer>=(60*4*1024*RecordLength)) or (EOF(DirectSoundFile));

  253.   VoiceLength:=VoicePointer;

  255.   Close(DirectSoundFile);
  256.   {$I+}
  257.   if IOResult<>0 then
  258.     Exit;

  260.   OpenVoice:=True;
  261. end;

  263. begin
  264.   SoundCardBasePort:=$220;
  265.   RecordLength:=5;
  266. end.
复制代码


-完-
回复

使用道具 举报

FlierMate.
 楼主| 发表于 4-3-2011 06:43 PM | 显示全部楼层
接下来，这是我自创的影像播放（没有采用压缩）的320x200x256格式。

影像播放模块：
  1. unit Movie;
  2. {
  3.   Direct Loading Video Service Unit
  4.   Revision 1997-1999
  5.   Researched and Developed Boo Khan Ming

  7.   Provide necessary code to display video at resolution of 320x200x256
  8.   consistently at predefined frame rate.

  10.   Video format established:

  12.          0-2            Video Format ID String (DLV)
  13.          3-4            Video Format Version Number
  14.          5-8            Total Frame
  15.          9-12           Frame Size (include palette)
  16.          13-14          Frame Rate (fps)
  17.          15-            DLP Picture (without header)


  20.   DLV Version 1.0

  22.   DLV Version 1.1      Added long description
  23.                        Added reserved space

  25.   DLV Version 1.2      Dynamic video size supported
  26.    Downward           (not necessary fixed at 320x200)
  27.     compatible
  28.     with DLV 1.1

  30.   .................

  32.   Unit Version 2.0     Total frame actual count supported

  34.   Unit Version 2.2     Enabled user frame rate

  36.   Unit Version 2.4     Reversed video playback supported

  38.                        Optimized video playback performance
  39.                        (reduced palette reprogramme jerky effect)

  41.   Unit Version 2.5     Significantly better video playback performance
  42.                        by preloading video data to extended memory (XMS)
  43. }

  45. interface

  47. type
  48.   VidHeaderRef=record
  49.     VidID:string[3];
  50.     VidVer:word;
  51.     Description:string;
  52.     Reserved:string[251];
  53.     Width:word;
  54.     Height:word;
  55.     TotalFrame:longint;
  56.     FrameSize:longint;
  57.     FrameRate:word;
  58.   end;

  60. procedure PrepareVideo;
  61. procedure ShutVideo;
  62. function OpenVideo(Filename:string):byte;
  63. procedure CloseVideo;
  64. function SeekFrame(Offset:longint):boolean;
  65. function LoadVideo:byte;
  66. procedure UnloadVideo;
  67. function PlayVideo(Mode:byte;UserFrameRate:word):boolean;
  68. function ReverseVideo(Mode:byte;UserFrameRate:word):boolean;
  69. function StepVideo(Mode:byte;StepRatio:word;UserFrameRate:word):boolean;
  70. function DiagnosticVideo(Mode:byte;StepRatio:word;var FrameRate:real;var Frame:longint):boolean;

  72. implementation

  74. uses CRT,DOS,Video,Mouse,Palette,Memory;

  76. const
  77.   VidIDRef:string[3]='DLV';

  79. type
  80.   VidPicRef=record
  81.     PicPal:array [1..768] of byte;
  82.     Pic:array [1..64000] of byte;
  83.   end;

  85. var
  86.   f:file;
  87.   r:registers;
  88.   l,c:longint;
  89.   Size:word;
  90.   VidPic:^VidPicRef;
  91.   VidHeader:VidHeaderRef;
  92.   VidHandle:word;
  93.   AdvancedPlayback:boolean;

  95. procedure PrepareVideo;
  96. begin
  97.   { prepare low resolution graphics screen }
  98.   asm
  99.     mov  ax, 0013h
  100.     int  10h
  101.   end;
  102. end;

  104. procedure ShutVideo;
  105. begin
  106.   TextMode(co80);
  107. end;

  109. function SeekFrame(Offset:longint):boolean;
  110. var
  111.   PalOfs:word;
  112.   PicSeg,PicOfs:word;
  113.   Width,Height:word;
  114.   VidOfs:longint;

  116. begin
  117.   SeekFrame:=False;

  119.   if AdvancedPlayback then
  120.   begin
  121.     VidOfs:=Offset-SizeOf(VidHeader);
  122.     TransferEMB(Longint(@VidPic^),0,VidOfs,VidHandle,VidHeader.FrameSize);
  123.     if XMSError<>0 then
  124.     begin
  125.       Exit;
  126.     end;
  127.   end
  128.   else
  129.   begin
  130.     {$I-}
  131.     Seek(f,Offset);
  132.     BlockRead(f,VidPic^,VidHeader.FrameSize);
  133.     {$I+}
  134.     if IOResult<>0 then
  135.       Exit;
  136.   end;

  138.   PalOfs:=Ofs(VidPic^.PicPal);
  139.   PicSeg:=Seg(VidPic^.Pic);
  140.   PicOfs:=Ofs(VidPic^.Pic);

  142.   Width:=VidHeader.Width;
  143.   Height:=VidHeader.Height;

  145.   if ((Width=320) and (Height=200))
  146.   or (VidHeader.VidVer<$0120) then
  147.   begin
  148.     asm
  149.       mov  ax, 1012h
  150.       xor  bx, bx
  151.       mov  cx, 256
  152.       mov  dx, PalOfs
  153.       int  10h
  154.       push ds
  155.       mov  ax, 0a000h
  156.       mov  es, ax
  157.       mov  ax, PicSeg
  158.       mov  ds, ax
  159.       xor  di, di
  160.       mov  si, PicOfs
  161.       mov  cx, 32000
  162.       rep  movsw
  163.       pop  ds
  164.     end;
  165.   end
  166.   else
  167.   begin
  168.     asm
  169.       mov  ax, 1012h
  170.       xor  bx, bx
  171.       mov  cx, 256
  172.       mov  dx, PalOfs
  173.       int  10h
  174.       push ds
  175.       mov  ax, 0a000h
  176.       mov  es, ax
  177.       mov  ax, PicSeg
  178.       mov  ds, ax
  179.       xor  di, di
  180.       mov  si, PicOfs
  181.       mov  cx, Height
  182.     @Draw:
  183.       push cx
  184.       mov  cx, Width
  185.       rep  movsb
  186.       add  di, 320
  187.       sub  di, Width
  188.       pop  cx
  189.       dec  cx
  190.       jnz  @Draw
  191.       pop  ds
  192.     end;
  193.   end;

  195.   SeekFrame:=True;
  196. end;

  198. function OpenVideo(Filename:string):byte;
  199. {
  200.   Error codes:  0=Successful
  201.                 1=Insufficient memory
  202.                 2=File open error
  203.                 3=Invalid video format
  204.                 255=Undefined error
  205. }

  207. begin
  208.   OpenVideo:=255;

  210.   AdvancedPlayback:=False;

  212.   { determine available memory }
  213.   if MaxAvail<SizeOf(VidPic^) then
  214.   begin
  215.     OpenVideo:=1;
  216.     Exit;
  217.   end;

  219.   { create new dynamic variable }
  220.   New(VidPic);

  222.   {$I-}
  223.   Assign(f,Filename);
  224.   Reset(f,1);

  226.   BlockRead(f,VidHeader,SizeOf(VidHeader));

  228.   {$I+}
  229.   if IOResult<>0 then
  230.   begin
  231.     OpenVideo:=2;
  232.     Exit;
  233.   end;

  235.   if VidHeader.VidID<>VidIDRef then
  236.   begin
  237.     OpenVideo:=3;
  238.     Exit;
  239.   end;

  241.   OpenVideo:=0;
  242. end;

  244. procedure CloseVideo;
  245. begin
  246.   {$I-}
  247.   Close(f);
  248.   {$I+}

  250.   { dispose dynamic variable }
  251.   Dispose(VidPic);
  252. end;

  254. function LoadVideo:byte;
  255. {
  256.   Error codes:  0=Successful
  257.                 1=XMS driver not installed
  258.                 2=Insufficient extended memory
  259.                 3=Unable to allocate extended memory
  260.                 4=Error encountered during video data transfer (loading)
  261.                 255=Undefined error
  262. }

  264. var
  265.   Offset:longint;

  267. begin
  268.   LoadVideo:=255;

  270.   AdvancedPlayback:=True;

  272.   if not XMSInstalled then
  273.   begin
  274.     LoadVideo:=1;
  275.     Exit;
  276.   end;

  278.   if EMBMaxAvail<(FileSize(f) div 1024) then
  279.   begin
  280.     LoadVideo:=2;
  281.     Exit;
  282.   end;

  284.   VidHandle:=AllocateEMB(FileSize(f) div 1024);
  285.   if XMSError<>0 then
  286.   begin
  287.     LoadVideo:=3;
  288.     Exit;
  289.   end;

  291.   Seek(f,SizeOf(VidHeader));
  292.   Offset:=0;

  294.   repeat
  295.     BlockRead(f,VidPic^,VidHeader.FrameSize,Size);
  296.     if Size<>0 then
  297.     begin
  298.       TransferEMB(Offset,VidHandle,Longint(@VidPic^),0,VidHeader.FrameSize);
  299.       Inc(Offset,VidHeader.FrameSize);

  301.       if XMSError<>0 then
  302.       begin
  303.         LoadVideo:=4;
  304.         Exit;
  305.       end;
  306.     end;
  307.   until (Size=0);

  309.   LoadVideo:=0;
  310. end;

  312. procedure UnloadVideo;
  313. begin
  314.   FreeEMB(VidHandle);
  315. end;

  317. function PlayVideo(Mode:byte;UserFrameRate:word):boolean;
  318. {
  319.   Modes:    0=Normal
  320.             1=Fast
  321.             2=Normal with UserFrameRate enabled
  322.             3=Fast with UserFrameRate enabled
  323. }

  325. var
  326.   VidPtr:longint;

  328. begin
  329.   PlayVideo:=False;

  331.   for l:=1 to VidHeader.TotalFrame do
  332.   begin
  333.     VidPtr:=((l-1)*VidHeader.FrameSize)+SizeOf(VidHeader);
  334.     if not SeekFrame(VidPtr) then
  335.       Exit;

  337.     if Keypressed then
  338.       Exit;
  339.     if GetMouseEvent<>0 then
  340.     begin
  341.       repeat until GetMouseEvent=0;

  343.       {PlayVideo:=True;}
  344.       Exit;
  345.     end;

  347.     if Mode=0 then
  348.       Delay(1000 div VidHeader.FrameRate)
  349.     else if Mode=2 then
  350.       Delay(1000 div UserFrameRate);
  351.   end;

  353.   PlayVideo:=True;
  354. end;

  356. function ReverseVideo(Mode:byte;UserFrameRate:word):boolean;
  357. {
  358.   Modes:    0=Normal
  359.             1=Fast
  360.             2=Normal with UserFrameRate enabled
  361.             3=Fast with UserFrameRate enabled
  362. }

  364. var
  365.   VidPtr:longint;

  367. begin
  368.   ReverseVideo:=False;

  370.   for l:=VidHeader.TotalFrame downto 1 do
  371.   begin
  372.     VidPtr:=((l-1)*VidHeader.FrameSize)+SizeOf(VidHeader);
  373.     if not SeekFrame(VidPtr) then
  374.       Exit;

  376.     if Keypressed then
  377.       Exit;
  378.     if GetMouseEvent<>0 then
  379.     begin
  380.       repeat until GetMouseEvent=0;
  381.       Exit;
  382.     end;

  384.     if Mode=0 then
  385.       Delay(1000 div VidHeader.FrameRate)
  386.     else if Mode=2 then
  387.       Delay(1000 div UserFrameRate);
  388.   end;

  390.   ReverseVideo:=True;
  391. end;

  393. function StepVideo(Mode:byte;StepRatio:word;UserFrameRate:word):boolean;
  394. {
  395.   Modes:    0=Normal
  396.             1=Fast
  397.             2=Normal with UserFrameRate enabled
  398.             3=Fast with UserFrameRate enabled
  399. }

  401. var
  402.   VidPtr:longint;

  404. begin
  405.   StepVideo:=False;

  407.   l:=1;

  409.   repeat
  410.     VidPtr:=((l-1)*VidHeader.FrameSize)+SizeOf(VidHeader);
  411.     if not SeekFrame(VidPtr) then
  412.       Exit;

  414.     if Keypressed then
  415.       Exit;

  417.     if Mode=0 then
  418.       Delay(1000 div VidHeader.FrameRate)
  419.     else if Mode=2 then
  420.       Delay(1000 div UserFrameRate);

  422.     Inc(l,StepRatio);
  423.   until l>VidHeader.TotalFrame;

  425.   StepVideo:=True;
  426. end;

  428. function DiagnosticVideo(Mode:byte;StepRatio:word;var FrameRate:real;var Frame:longint):boolean;
  429. {
  430.   Modes:    0=Normal
  431.             1=Fast
  432. }

  434. var
  435.   VidPtr:longint;
  436.   Hour,Min,Sec,Sec100:word;
  437.   OldMin,NewMin:word;
  438.   OldSec,NewSec:word;
  439.   FrameTick:real;

  441. begin
  442.   DiagnosticVideo:=False;

  444.   repeat
  445.     GetTime(Hour,Min,Sec,Sec100);
  446.   until Sec100=0;

  448.   OldMin:=Min;
  449.   OldSec:=Sec;
  450.   FrameRate:=0;
  451.   Frame:=0;

  453.   l:=1;

  455.   repeat
  456.     VidPtr:=((l-1)*VidHeader.FrameSize)+SizeOf(VidHeader);
  457.     if not SeekFrame(VidPtr) then
  458.       Exit;

  460.     if Mode=0 then
  461.       Delay(1000 div VidHeader.FrameRate);

  463.     Inc(l,StepRatio);

  465.     Inc(Frame);
  466.   until l>VidHeader.TotalFrame;

  468.   GetTime(Hour,Min,Sec,Sec100);

  470.   NewMin:=Min;
  471.   NewSec:=Sec;

  473.   if NewMin<OldMin then
  474.     NewMin:=NewMin+60;
  475.   if Sec100=0 then
  476.     Sec100:=1;

  478.   { compute frame rate using timer tick }
  479.   FrameTick:=((NewMin*60)+NewSec)-((OldMin*60)+OldSec)+(1/Sec100);
  480.   FrameRate:=VidHeader.TotalFrame/FrameTick;

  482.   DiagnosticVideo:=True;
  483. end;

  485. end.
复制代码
回复

使用道具 举报

FlierMate.
 楼主| 发表于 4-3-2011 06:46 PM | 显示全部楼层
楼上的影像播放动用到内存模块（除了中断DOS Interrupt部分是采用别人的，其他都是自编的）：

  1. {$G+}
  2. unit Memory;
  3. {
  4.   Memory Service Unit
  5.   Revision 1 (1998)
  6.   Developed by Boo Khan Ming

  8.   Provide all available functions and procedures to utilise the
  9.   XMS (Extended Memory), UMB (Upper Memory Block) and the heap.

  11.   The XMS interrupt call routines are based on external source.
  12. }

  14. interface

  16. var
  17.   XMSHandler:pointer;
  18.   XMSInstalled:boolean;
  19.   XMSError:byte;

  21. function ShrinkHeap:boolean;
  22. procedure ExpandHeap;
  23. procedure CopyMemory(Source,Destination,Count:word);
  24. function DumpMemory(Segment,Offset:word):string;
  25. function FindMemory(StartSegment,EndSegment:word;var FoundSegment,FoundOffset:word;FindString:string):boolean;

  27. function GetXMSVersion:longint;
  28. function RequestHMA(Size:word):boolean;
  29. function ReleaseHMA:boolean;
  30. function GlobalEnableA20:boolean;
  31. function GlobalDisableA20:boolean;
  32. function LocalEnableA20:boolean;
  33. function LocalDisableA20:boolean;
  34. function QueryA20:boolean;
  35. function EMBMaxAvail:word;
  36. function EMBMemAvail:word;
  37. function AllocateEMB(Size:word):word;
  38. function FreeEMB(Handle:word):boolean;
  39. function TransferEMB(DestinationOffset:longint;DestinationHandle:word;
  40.                      SourceOffset:longint;SourceHandle:word;
  41.                      Count:longint):boolean;
  42. function LockEMB(Handle:word):longint;
  43. function UnlockEMB(Handle:word):boolean;
  44. function GetEMBHandleInfo(Handle:word;var LockCount,FreeHandles:byte;var BlockSize:word):boolean;
  45. function ReallocateEMB(Handle:word;NewSize:word):boolean;
  46. function RequestUMB(Size:word):word;
  47. function ReleaseUMB(Segment:word):boolean;
  48. function UMBMemAvail:word;

  50. implementation

  52. function ShrinkHeap:boolean;
  53. var
  54.   Size:word;

  56. begin
  57.   Size:=MemW[Seg(HeapPtr):Ofs(HeapPtr)+2]-PrefixSeg+1;

  59.   asm
  60.     mov  bx, Size
  61.     mov  es, PrefixSeg
  62.     mov  ah, 4ah
  63.     int  21h

  65.     jc   @error
  66.     sub  al, al
  67.     jmp  @exit

  69.   @error:
  70.     mov  al, 01h
  71.   @exit:
  72.   end;
  73. end;

  75. procedure ExpandHeap;
  76. var
  77.   Size:word;

  79. begin
  80.   Size:=MemW[Seg(HeapEnd):Ofs(HeapEnd)+2]-PrefixSeg;

  82.   asm
  83.     mov  bx, Size
  84.     mov  es, PrefixSeg
  85.     mov  ah, 4ah
  86.     int  21h
  87.   end;
  88. end;

  90. procedure CopyMemory(Source,Destination,Count:word); assembler;
  91. asm
  92.   push ds
  93.   mov  ax, Source
  94.   mov  ds, ax
  95.   mov  ax, Destination
  96.   mov  es, ax
  97.   xor  si, si
  98.   xor  di, di
  99.   mov  cx, Count
  100.   rep  movsw
  101.   pop  ds
  102. end;

  104. function DumpMemory(Segment,Offset:word):string;
  105. var
  106.   Scan:^byte;
  107.   Range:word;
  108.   Content:string;

  110. begin
  111.   Range:=0;
  112.   Content:='';

  114.   repeat
  115.     Scan:=Ptr(Segment,Offset+Range);
  116.     if Scan^=0 then
  117.       Break;

  119.     Content:=Content+Chr(Scan^);
  120.     Inc(Range);
  121.   until Range>255;

  123.   DumpMemory:=Content;
  124. end;

  126. function FindMemory(StartSegment,EndSegment:word;var FoundSegment,FoundOffset:word;FindString:string):boolean;
  127. var
  128.   Scan:^byte;
  129.   SegmentPtr,OffsetPtr:longint;
  130.   Counter:byte;
  131.   Found:boolean;

  133. begin
  134.   FindMemory:=False;
  135.   Found:=False;

  137.   for SegmentPtr:=StartSegment to EndSegment do
  138.   begin
  139.     for OffsetPtr:=$0000 to $FFFF do
  140.     begin
  141.       Scan:=Ptr(SegmentPtr,OffsetPtr);

  143.       if UpCase(Chr(Scan^))=UpCase(FindString[1]) then
  144.       begin
  145.         for Counter:=1 to Length(FindString)-1 do
  146.         begin
  147.           Scan:=Ptr(SegmentPtr,OffsetPtr+Counter);
  148.           if UpCase(Chr(Scan^))<>UpCase(FindString[Counter+1]) then
  149.           begin
  150.             Found:=False;
  151.             Break;
  152.           end
  153.           else
  154.             Found:=True;
  155.         end;
  156.       end;

  158.       if Found then
  159.         Break;
  160.     end;

  162.     if Found then
  163.       Break;
  164.   end;

  166.   if Found then
  167.   begin
  168.     FindMemory:=True;

  170.     FoundSegment:=SegmentPtr;
  171.     FoundOffset:=OffsetPtr;
  172.   end;
  173. end;

  175. procedure XMSInterrupt; near; assembler;
  176. asm
  177.   push  SEG @DATA
  178.   pop   es
  179.   cmp   es:[XMSInstalled], 1
  180.   jnz   @fail
  181.   call  DWORD PTR es:[XMSHandler]
  182.   or    ax, ax
  183.   jnz   @success
  184.   push  ds
  185.   push  es
  186.   pop   ds
  187.   mov   XMSError, bl
  188.   pop   ds
  189. @fail:
  190.   xor   ax, ax
  191. @success:
  192. end;

  194. function GetXMSVersion:longint; assembler;
  195. asm
  196.   xor  ax, ax
  197.   xor  dx, dx
  198.   sub  ah, ah
  199.   call XMSInterrupt
  200.   xchg dx, bx
  201. end;

  203. function RequestHMA(Size:word):boolean; assembler;
  204. asm
  205.   mov  ah, 01h
  206.   call XMSInterrupt
  207. end;

  209. function ReleaseHMA:boolean; assembler;
  210. asm
  211.   mov  ah, 02h
  212.   call XMSInterrupt
  213. end;

  215. function GlobalEnableA20:boolean; assembler;
  216. asm
  217.   mov  ah, 03h
  218.   call XMSInterrupt
  219. end;

  221. function GlobalDisableA20:boolean; assembler;
  222. asm
  223.   mov  ah, 04h
  224.   call XMSInterrupt
  225. end;

  227. function LocalEnableA20:boolean; assembler;
  228. asm
  229.   mov  ah, 05h
  230.   call XMSInterrupt
  231. end;

  233. function LocalDisableA20:boolean; assembler;
  234. asm
  235.   mov  ah, 06h
  236.   call XMSInterrupt
  237. end;

  239. function QueryA20:boolean; assembler;
  240. asm
  241.   mov  ah, 07h
  242.   call XMSInterrupt
  243. end;

  245. function EMBMaxAvail:word; assembler;
  246. asm
  247.   mov  ah, 08h
  248.   call XMSInterrupt
  249. end;

  251. function EMBMemAvail:word; assembler;
  252. asm
  253.   xor  dx, dx
  254.   mov  ah, 08h
  255.   call XMSInterrupt
  256.   mov  ax, dx
  257. end;

  259. function AllocateEMB(Size:word):word; assembler;
  260. asm
  261.   mov  ah, 09h
  262.   mov  dx, Size
  263.   call XMSInterrupt
  264.   or   al, al
  265.   jz   @finish
  266.   mov  ax, dx
  267. @finish:
  268. end;

  270. function FreeEMB(Handle:word):boolean; assembler;
  271. asm
  272.   mov  dx, Handle
  273.   mov  ah, 0ah
  274.   call XMSInterrupt
  275. end;

  277. function TransferEMB(DestinationOffset:longint;DestinationHandle:word;
  278.                      SourceOffset:longint;SourceHandle:word;
  279.                      Count:longint):boolean;
  280. begin
  281.   asm
  282.     push ds
  283.     push ss
  284.     pop  ds
  285.     lea  si, Count
  286.     mov  ah, 0bh
  287.     call XMSInterrupt
  288.     mov  @Result, al
  289.     pop  ds
  290.   end
  291. end;

  293. function LockEMB(Handle:word):longint; assembler;
  294. asm
  295.   mov  ah, 0ch
  296.   mov  dx, handle
  297.   call XMSInterrupt
  298.   mov  ax, bx
  299. end;

  301. function UnlockEMB(Handle:word):boolean; assembler;
  302. asm
  303.   mov  ah, 0dh
  304.   mov  dx, Handle
  305.   call XMSInterrupt
  306. end;

  308. function GetEMBHandleInfo(Handle:word;var LockCount,FreeHandles:byte;var BlockSize:word):boolean; assembler;
  309. asm
  310.   mov  dx, Handle
  311.   mov  ah, 0eh
  312.   call XMSInterrupt
  313.   les  di, LockCount
  314.   mov  BYTE PTR es:[di], bh
  315.   les  di, FreeHandles
  316.   mov  BYTE PTR es:[di], bl
  317.   les  di, BlockSize
  318.   mov  WORD PTR es:[di], dx
  319. end;

  321. function ReallocateEMB(Handle:word;NewSize:word):boolean; assembler;
  322. asm
  323.   mov  ah, 0fh
  324.   mov  bx, NewSize
  325.   mov  dx, Handle
  326.   call XMSInterrupt
  327. end;

  329. function RequestUMB(Size:word):word; assembler;
  330. asm
  331.   mov  ah, 10h
  332.   mov  dx, Size
  333.   call XMSInterrupt
  334.   mov  ax, bx
  335. end;

  337. function ReleaseUMB(Segment:word):boolean; assembler;
  338. asm
  339.   mov  ah, 11h
  340.   mov  dx, Segment
  341.   call XMSInterrupt
  342. end;

  344. function UMBMemAvail:word; assembler;
  345. asm
  346.   mov  ah, 10h
  347.   mov  dx, 0ffffh
  348.   call XMSInterrupt
  349.   mov  ax, dx
  350. end;

  352. begin
  353.   asm
  354.     mov  ax, 4300h
  355.     int  2fh
  356.     cmp  al, 80h
  357.     jnz  @false
  358.     mov  ax, 4310h
  359.     int  2fh
  360.     mov  WORD PTR XMSHandler[0], bx
  361.     mov  WORD PTR XMSHandler[2], es
  362.     mov  XMSInstalled, 1
  363.     jmp  @true
  364.   @false:
  365.     mov  XMSInstalled, 0
  366.   @true:
  367.   end;
  368. end.
复制代码
回复

使用道具 举报

Follow Us
FlierMate.
 楼主| 发表于 4-3-2011 06:49 PM | 显示全部楼层
除此之外，也需要用到彩色盘（Palette）的模块。
256色减至16色的颜色处理是我自研的技术。

  1. unit Palette;
  2. {
  3.   Palette Service Unit
  4.   Revision 2 (1998-1999)
  5.   Developed by Boo Khan Ming

  7.   Provide access to the video color palette and color processing options.
  8. }

  10. interface

  12. procedure SetPalette(PalReg,PalVal:byte);
  13. procedure SetPalette256(Color,Red,Green,Blue:byte);
  14. procedure GetPalette256(Color:byte;var Red,Green,Blue:byte);
  15. procedure SetIntensity(Level:byte);
  16. procedure GetIntensity;
  17. procedure InvertGraphicsPalette;
  18. procedure IncreaseBrightness;
  19. procedure DecreaseBrightness;
  20. function SimplifyColorComponent(Value:byte):byte;
  21. function DecreaseColor256(Red,Green,Blue:byte):byte;

  23. implementation

  25. type
  26.   ColorType=record
  27.     Red,Green,Blue:byte;
  28.   end;

  30. var
  31.   ColorTable:array [0..63] of ColorType;
  32.   VideoPal:array [0..255,0..2] of byte;
  33.   Color:byte;
  34.   Counter:word;
  35.   PalLevel:byte;
  36.   PalRedRatio,PalGreenRatio,PalBlueRatio:byte;

  38. procedure SetPalette(PalReg,PalVal:byte); assembler;
  39. asm
  40.   mov  ax, 1000h
  41.   mov  bl, PalReg
  42.   mov  bh, PalVal
  43.   int  10h
  44. end;

  46. procedure SetPalette256(Color,Red,Green,Blue:byte); assembler;
  47. asm
  48.   mov  dx, 03c8h
  49.   mov  al, Color
  50.   out  dx, al
  51.   inc  dx
  52.   mov  al, Red
  53.   mov  cl, 2
  54.   shr  al, cl
  55.   out  dx, al
  56.   mov  al, Green
  57.   mov  cl, 2
  58.   shr  al, cl
  59.   out  dx, al
  60.   mov  al, Blue
  61.   mov  cl, 2
  62.   shr  al, cl
  63.   out  dx, al
  64. end;

  66. procedure GetPalette256(Color:byte;var Red,Green,Blue:byte);
  67. begin
  68.   Port[$03c7]:=Color;
  69.   Red:=Port[$03c9];
  70.   Green:=Port[$03c9];
  71.   Blue:=Port[$03c9];
  72. end;

  74. procedure SetIntensity(Level:byte);
  75. begin
  76.   for Color:=0 to 63 do
  77.     SetPalette256(Color,ColorTable[Color].Red*Level div 63,
  78.                     ColorTable[Color].Green*Level div 63,
  79.                     ColorTable[Color].Blue*Level div 63);
  80. end;

  82. procedure GetIntensity;
  83. begin
  84.   for Color:=0 to 63 do
  85.     GetPalette256(Color,ColorTable[Color].Red,ColorTable[Color].Green,ColorTable[Color].Blue);
  86. end;

  88. procedure InvertGraphicsPalette;
  89. begin
  90.   for Counter:=0 to 255 do
  91.   begin
  92.     Port[$03c7]:=Counter;
  93.     VideoPal[Counter,0]:=Port[$03c9];
  94.     VideoPal[Counter,1]:=Port[$03c9];
  95.     VideoPal[Counter,2]:=Port[$03c9];
  96.   end;

  98.   for Counter:=0 to 255 do
  99.   begin
  100.     VideoPal[Counter,0]:=not VideoPal[Counter,0];
  101.     VideoPal[Counter,1]:=not VideoPal[Counter,1];
  102.     VideoPal[Counter,2]:=not VideoPal[Counter,2];

  104.     Port[$03c8]:=Counter;
  105.     Port[$03c9]:=VideoPal[Counter,0];
  106.     Port[$03c9]:=VideoPal[Counter,1];
  107.     Port[$03c9]:=VideoPal[Counter,2];
  108.   end;
  109. end;

  111. procedure IncreaseBrightness;
  112. begin
  113.   for Counter:=0 to 255 do
  114.   begin
  115.     Port[$03c7]:=Counter;
  116.     VideoPal[Counter,0]:=Port[$03c9];
  117.     VideoPal[Counter,1]:=Port[$03c9];
  118.     VideoPal[Counter,2]:=Port[$03c9];
  119.   end;

  121.   for Counter:=0 to 255 do
  122.   begin
  123.     for PalLevel:=0 to 2 do
  124.     begin
  125.       if VideoPal[Counter,PalLevel]<63 then
  126.         Inc(VideoPal[Counter,PalLevel]);
  127.     end;

  129.     Port[$03c8]:=Counter;
  130.     Port[$03c9]:=VideoPal[Counter,0];
  131.     Port[$03c9]:=VideoPal[Counter,1];
  132.     Port[$03c9]:=VideoPal[Counter,2];
  133.   end;
  134. end;

  136. procedure DecreaseBrightness;
  137. begin
  138.   for Counter:=0 to 255 do
  139.   begin
  140.     Port[$03c7]:=Counter;
  141.     VideoPal[Counter,0]:=Port[$03c9];
  142.     VideoPal[Counter,1]:=Port[$03c9];
  143.     VideoPal[Counter,2]:=Port[$03c9];
  144.   end;

  146.   for Counter:=0 to 255 do
  147.   begin
  148.     for PalLevel:=0 to 2 do
  149.     begin
  150.       if VideoPal[Counter,PalLevel]>0 then
  151.         Dec(VideoPal[Counter,PalLevel]);
  152.     end;

  154.     Port[$03c8]:=Counter;
  155.     Port[$03c9]:=VideoPal[Counter,0];
  156.     Port[$03c9]:=VideoPal[Counter,1];
  157.     Port[$03c9]:=VideoPal[Counter,2];
  158.   end;
  159. end;

  161. function SimplifyColorComponent(Value:byte):byte;
  162. begin
  163.   if Value>=52 then
  164.     SimplifyColorComponent:=63
  165.   else
  166.   if Value>=32 then
  167.     SimplifyColorComponent:=42
  168.   else
  169.   if Value>=12 then
  170.     SimplifyColorComponent:=21
  171.   else
  172.     SimplifyColorComponent:=0;
  173. end;

  175. function DecreaseColor256(Red,Green,Blue:byte):byte;
  176. const
  177.   Palette16:array [0..15,1..3] of byte=((0,0,0),(0,0,42),(0,42,0),(0,42,42),
  178.                                         (42,0,0),(42,0,42),(42,42,0),(42,42,42),
  179.                                         (0,0,21),(0,0,63),(0,42,21),(0,42,63),
  180.                                         (42,0,21),(42,0,63),(42,42,21),(42,42,63));
  181. var
  182.   Color,Component,Value:byte;
  183.   NewRed,NewGreen,NewBlue:byte;

  185. begin
  186.   DecreaseColor256:=0;
  187.   Component:=1;

  189.   repeat
  190.     case Component of
  191.       1:Value:=SimplifyColorComponent(Red div 4);
  192.       2:Value:=SimplifyColorComponent(Green div 4);
  193.       3:Value:=SimplifyColorComponent(Blue div 4);
  194.     end;

  196.     Color:=0;

  198.     while Value<>Palette16[Color,Component] do
  199.     begin
  200.       Inc(Color);

  202.       if Color>15 then
  203.       begin
  204.         Dec(Value,21);
  205.         Color:=0;
  206.       end;
  207.     end;

  209.     case Component of
  210.       1:NewRed:=Value;
  211.       2:NewGreen:=Value;
  212.       3:NewBlue:=Value;
  213.     end;

  215.     Inc(Component);

  217.   until Component>3;

  219.   for Color:=0 to 15 do
  220.     if (Palette16[Color,1]=NewRed) and (Palette16[Color,2]=NewGreen)
  221.     and (Palette16[Color,3]=NewBlue) then
  222.     begin
  223.       DecreaseColor256:=Color;
  224.       Exit;
  225.     end;
  226. end;

  228. end.
复制代码
回复

使用道具 举报

FlierMate.
 楼主| 发表于 4-3-2011 06:53 PM | 显示全部楼层
至于另外的Video、Mouse模块很普通（大家的都是一样的），在这里就不列出来了。
回复

使用道具 举报


ADVERTISEMENT

FlierMate_
发表于 4-3-2011 10:24 PM | 显示全部楼层
再来就是自行研发类似RLE(Run-Length Encoding)低效率的压缩技术----SqueezeTogether。

  1. unit Compress;
  2. {
  3.   Squeeze-Together(im) Compression Technology
  4.   Revision 1 (1999)
  5.   Researched and Developed by Boo Khan Ming

  7.   Compress all types of file regardless of file size.
  8. }

  10. interface

  12. function SqueezeFile(InputFileName,OutputFileName:string):byte;
  13. function StretchFile(InputFileName,OutputFileName:string):byte;

  15. implementation

  17. uses DOS;

  19. type
  20.   DataType=array [0..63999] of byte;

  22. var
  23.   Data:^DataType;
  24.   DataSize:longint;
  25.   SegmentIndex:longint;

  27.   InputFile:file;
  28.   OutputFile:file;

  30.   FrequencyTable:array [1..256] of word;
  31.   FrequencyTableSize:word;

  33.   UsedCodeList,UnusedCodeList:array [1..256] of byte;
  34.   UsedCode,UnusedCode:word;

  36.   FrequentlyUsedCodeList:array [1..256] of byte;
  37.   CodeMap:array [1..256] of longint;

  39.   Counter:longint;
  40.   Loop:word;
  41.   Code:byte;
  42.   Frequency:byte;
  43.   CollectMode:boolean;
  44.   Found:boolean;
  45.   AccessStatus:word;
  46.   FileDateTime:longint;

  48.   P1,P2:PathStr;
  49.   D1,D2:DirStr;
  50.   N1,N2:NameStr;
  51.   E1,E2:ExtStr;

  53. function SqueezeFile(InputFileName,OutputFileName:string):byte;
  54. {
  55.   Status Code
  56.   0 = Successful
  57.   1 = Insufficient Memory
  58.   2 = Unable to open input file
  59.   3 = File access error
  60.   4 = Unable to compress file
  61.   5 = Unable to create output file
  62.   255 = Undefined error
  63. }

  65.   function FetchCode(Index:longint):byte;
  66.   var
  67.     Refresh:boolean;

  69.   begin
  70.     FetchCode:=0;

  72.     if Index-1>DataSize then
  73.       Exit;

  75.     Refresh:=False;

  77.     if ((Index-1) div 64000)<>SegmentIndex then
  78.     begin
  79.       SegmentIndex:=(Index-1) div 64000;
  80.       Refresh:=True;
  81.     end;

  83.     if Refresh then
  84.     begin
  85.       {$I-}
  86.       Seek(InputFile,SegmentIndex*64000);
  87.       BlockRead(InputFile,Data^,64000,AccessStatus);
  88.       {$I+}
  89.       if IOResult<>0 then
  90.       begin
  91.         SqueezeFile:=3;
  92.         Exit;
  93.       end;
  94.     end;

  96.     FetchCode:=Data^[(Index-1) mod 64000];
  97.   end;

  99.   procedure AnalyseUsedCode;
  100.   var
  101.     Counter:longint;
  102.     Loop:word;
  103.     Found:boolean;

  105.   begin
  106.     UsedCode:=0;
  107.     FillChar(UsedCodeList,SizeOf(UsedCodeList),0);

  109.     for Counter:=1 to DataSize do
  110.     begin
  111.       Code:=FetchCode(Counter);
  112.       Inc(CodeMap[Code+1]);

  114.       Found:=False;

  116.       for Loop:=1 to UsedCode do
  117.         if UsedCodeList[Loop]=Code then
  118.         begin
  119.           Found:=True;
  120.           Break;
  121.         end;

  123.       if not Found then
  124.       begin
  125.         Inc(UsedCode);
  126.         UsedCodeList[UsedCode]:=Code;
  127.       end;
  128.     end;
  129.   end;

  131.   procedure AnalyseUnusedCode;
  132.   var
  133.     Counter:word;
  134.     Loop:word;
  135.     Found:boolean;

  137.   begin
  138.     UnusedCode:=0;
  139.     FillChar(UnusedCodeList,SizeOf(UnusedCodeList),0);

  141.     for Counter:=0 to 255 do
  142.     begin
  143.       Found:=False;

  145.       for Loop:=1 to UsedCode do
  146.         if UsedCodeList[Loop]=Counter then
  147.         begin
  148.           Found:=True;
  149.           Break;
  150.         end;

  152.       if not Found then
  153.       begin
  154.         Inc(UnusedCode);
  155.         UnusedCodeList[UnusedCode]:=Counter;
  156.       end;
  157.     end;
  158.   end;

  160.   procedure AnalyseFrequentlyUsedCode;
  161.   var
  162.     Loop1,Loop2:word;
  163.     Frequency:longint;
  164.     Index:byte;
  165.     Code:word;

  167.   begin
  168.     for Code:=1 to 256 do
  169.       FrequentlyUsedCodeList[Code]:=Code-1;

  171.     for Loop1:=2 to 256 do
  172.     begin
  173.       Frequency:=CodeMap[Loop1];
  174.       Index:=FrequentlyUsedCodeList[Loop1];

  176.       Loop2:=Loop1-1;

  178.       while (Frequency>CodeMap[Loop2]) and (Loop2>0) do
  179.       begin
  180.         CodeMap[Loop2+1]:=CodeMap[Loop2];
  181.         FrequentlyUsedCodeList[Loop2+1]:=FrequentlyUsedCodeList[Loop2];

  183.         Loop2:=Loop2-1;
  184.       end;

  186.       CodeMap[Loop2+1]:=Frequency;
  187.       FrequentlyUsedCodeList[Loop2+1]:=Index;
  188.     end;
  189.   end;

  191.   function FindReferenceIndex(Code:byte):byte;
  192.   var
  193.     Loop:word;

  195.   begin
  196.     FindReferenceIndex:=0;

  198.     for Loop:=1 to FrequencyTableSize do
  199.       if FrequentlyUsedCodeList[Loop]=Code then
  200.       begin
  201.         FindReferenceIndex:=UnusedCodeList[Loop];
  202.         Break;
  203.       end;
  204.   end;

  206.   function FindCodeIndex(Code:byte):byte;
  207.   var
  208.     Loop:word;

  210.   begin
  211.     FindCodeIndex:=0;

  213.     for Loop:=1 to FrequencyTableSize do
  214.       if UnusedCodeList[Loop]=Code then
  215.       begin
  216.         FindCodeIndex:=FrequentlyUsedCodeList[Loop];
  217.         Break;
  218.       end;
  219.   end;

  221.   procedure StoreCode;
  222.   begin
  223.     Code:=FetchCode(Counter);

  225.     BlockWrite(OutputFile,Code,1);
  226.   end;

  228.   procedure CompactCode;
  229.   begin
  230.     Code:=FindReferenceIndex(FetchCode(Counter-1));

  232.     BlockWrite(OutputFile,Code,1);
  233.     BlockWrite(OutputFile,Frequency,1);

  235.     Frequency:=0;
  236.   end;

  238. begin
  239.   SqueezeFile:=255;

  241.   if MaxAvail<64000 then
  242.   begin
  243.     SqueezeFile:=1;
  244.     Exit;
  245.   end;

  247.   {$I-}
  248.   Assign(InputFile,InputFileName);
  249.   Reset(InputFile,1);
  250.   {$I+}
  251.   if (IOResult<>0) or (FileSize(InputFile)=0) then
  252.   begin
  253.     SqueezeFile:=2;
  254.     Exit;
  255.   end;

  257.   DataSize:=FileSize(InputFile);
  258.   SegmentIndex:=0;

  260.   New(Data);

  262.   {$I-}
  263.   Seek(InputFile,SegmentIndex*64000);
  264.   BlockRead(InputFile,Data^,64000,AccessStatus);
  265.   {$I+}
  266.   if IOResult<>0 then
  267.   begin
  268.     SqueezeFile:=3;
  269.     Exit;
  270.   end;

  272.   AnalyseUsedCode;
  273.   AnalyseUnusedCode;
  274.   AnalyseFrequentlyUsedCode;

  276.   if UnusedCode=0 then
  277.   begin
  278.     SqueezeFile:=4;
  279.     Exit;
  280.   end;

  282.   P1:=InputFileName;
  283.   P2:=OutputFileName;
  284.   FSplit(P1,D1,N1,E1);
  285.   FSplit(P2,D2,N2,E2);

  287.   if (D2='') and (D1<>'') then
  288.   begin
  289.     D2:=D1;
  290.     P2:=D2+N2+E2;
  291.   end;

  293.   {$I-}
  294.   Assign(OutputFile,P2);
  295.   Rewrite(OutputFile,1);
  296.   {$I+}
  297.   if IOResult<>0 then
  298.   begin
  299.     SqueezeFile:=5;
  300.     Exit;
  301.   end;

  303.   if UnusedCode>UsedCode then
  304.     FrequencyTableSize:=UsedCode
  305.   else
  306.     FrequencyTableSize:=UnusedCode;

  308.   for Counter:=1 to FrequencyTableSize do
  309.     FrequencyTable[Counter]:=(UnusedCodeList[Counter] shl 8)+FrequentlyUsedCodeList[Counter];

  311.   BlockWrite(OutputFile,FrequencyTableSize,2);
  312.   BlockWrite(OutputFile,FrequencyTable,FrequencyTableSize*2);

  314.   Counter:=1;
  315.   Frequency:=0;
  316.   CollectMode:=False;

  318.   repeat
  319.     Found:=False;

  321.     for Loop:=1 to FrequencyTableSize do
  322.       if FetchCode(Counter)=FrequentlyUsedCodeList[Loop] then
  323.       begin
  324.         Found:=True;
  325.         Break;
  326.       end;

  328.     if CollectMode then
  329.       if FetchCode(Counter)<>FetchCode(Counter-1) then
  330.       begin
  331.         CompactCode;
  332.         CollectMode:=False;
  333.       end;

  335.     if (Found) or (CollectMode) then
  336.     begin
  337.       if Counter+2<DataSize then
  338.       begin
  339.         if (FetchCode(Counter)=FetchCode(Counter+1)) and (Frequency<252) then
  340.         begin
  341.           if (FetchCode(Counter+1)=FetchCode(Counter+2)) and (Frequency<252) then
  342.           begin
  343.             Inc(Frequency,3);
  344.             Inc(Counter,3);

  346.             CollectMode:=True;
  347.           end
  348.           else
  349.           begin
  350.             Inc(Frequency,2);
  351.             Inc(Counter,2);

  353.             CollectMode:=False;

  355.             CompactCode;
  356.           end;
  357.         end
  358.         else
  359.           CollectMode:=False;
  360.       end
  361.       else
  362.         CollectMode:=False;

  364.       if not CollectMode then
  365.         if Frequency>0 then
  366.         begin
  367.           Inc(Frequency);
  368.           Inc(Counter);

  370.           CompactCode;
  371.         end
  372.         else
  373.         begin
  374.           StoreCode;
  375.           Inc(Counter);
  376.         end;
  377.     end
  378.     else
  379.     begin
  380.       StoreCode;
  381.       Inc(Counter);
  382.     end;
  383.   until (Counter>DataSize) and (Frequency=0);

  385.   GetFTime(InputFile,FileDateTime);
  386.   SetFTime(OutputFile,FileDateTime);

  388.   Close(InputFile);
  389.   Close(OutputFile);

  391.   Dispose(Data);

  393.   SqueezeFile:=0;
  394. end;
复制代码
回复

使用道具 举报

FlierMate_
发表于 4-3-2011 10:25 PM | 显示全部楼层

……续上

  1. function StretchFile(InputFileName,OutputFileName:string):byte;
  2. {
  3.   Status Code
  4.   0 = Successful
  5.   1 = Insufficient Memory
  6.   2 = Unable to open input file
  7.   3 = File access error
  8.   5 = Unable to create output file
  9.   255 = Undefined error
  10. }

  12.   function FetchCode(Index:longint):byte;
  13.   var
  14.     Refresh:boolean;
  15.     SeekIndex:longint;

  17.   begin
  18.     FetchCode:=0;

  20.     if Index-1>DataSize-((FrequencyTableSize*2)+2) then
  21.       Exit;

  23.     Refresh:=False;

  25.     if ((Index-1) div 64000)<>SegmentIndex then
  26.     begin
  27.       SegmentIndex:=(Index-1) div 64000;
  28.       Refresh:=True;
  29.     end;

  31.     if Refresh then
  32.     begin
  33.       SeekIndex:=((FrequencyTableSize*2)+2)+(SegmentIndex*64000);

  35.       {$I-}
  36.       Seek(InputFile,SeekIndex);
  37.       BlockRead(InputFile,Data^,64000,AccessStatus);
  38.       {$I+}
  39.       if IOResult<>0 then
  40.       begin
  41.         StretchFile:=3;
  42.         Exit;
  43.       end;
  44.     end;

  46.     FetchCode:=Data^[(Index-1) mod 64000];
  47.   end;

  49. begin
  50.   StretchFile:=255;

  52.   if MaxAvail<64000 then
  53.   begin
  54.     StretchFile:=1;
  55.     Exit;
  56.   end;

  58.   {$I-}
  59.   Assign(InputFile,InputFileName);
  60.   Reset(InputFile,1);
  61.   {$I+}
  62.   if (IOResult<>0) or (FileSize(InputFile)=0) then
  63.   begin
  64.     StretchFile:=2;
  65.     Exit;
  66.   end;

  68.   DataSize:=FileSize(InputFile);
  69.   SegmentIndex:=0;

  71.   New(Data);

  73.   {$I-}
  74.   BlockRead(InputFile,FrequencyTableSize,2);
  75.   BlockRead(InputFile,FrequencyTable,FrequencyTableSize*2);
  76.   {$I+}
  77.   if IOResult<>0 then
  78.   begin
  79.     StretchFile:=3;
  80.     Exit;
  81.   end;

  83.   {$I-}
  84.   BlockRead(InputFile,Data^,64000,AccessStatus);
  85.   {$I+}
  86.   if IOResult<>0 then
  87.   begin
  88.     StretchFile:=3;
  89.     Exit;
  90.   end;

  92.   P1:=InputFileName;
  93.   P2:=OutputFileName;
  94.   FSplit(P1,D1,N1,E1);
  95.   FSplit(P2,D2,N2,E2);

  97.   if (D2='') and (D1<>'') then
  98.   begin
  99.     D2:=D1;
  100.     P2:=D2+N2+E2;
  101.   end;

  103.   {$I-}
  104.   Assign(OutputFile,P2);
  105.   Rewrite(OutputFile,1);
  106.   {$I+}
  107.   if IOResult<>0 then
  108.   begin
  109.     StretchFile:=5;
  110.     Exit;
  111.   end;

  113.   Counter:=1;

  115.   repeat
  116.     Found:=False;

  118.     for Loop:=1 to FrequencyTableSize do
  119.       if FetchCode(Counter)=Byte(FrequencyTable[Loop] shr 8) then
  120.       begin
  121.         Code:=Byte(FrequencyTable[Loop]);
  122.         Frequency:=FetchCode(Counter+1);
  123.         Inc(Counter,2);

  125.         Found:=True;
  126.         Break;
  127.       end;

  129.     if Found then
  130.     begin
  131.       for Loop:=1 to Frequency do
  132.         BlockWrite(OutputFile,Code,1);
  133.     end
  134.     else
  135.     begin
  136.       Code:=FetchCode(Counter);
  137.       BlockWrite(OutputFile,Code,1);
  138.       Inc(Counter);
  139.     end;
  140.   until Counter>DataSize-((FrequencyTableSize*2)+2);

  142.   GetFTime(InputFile,FileDateTime);
  143.   SetFTime(OutputFile,FileDateTime);

  145.   Close(InputFile);
  146.   Close(OutputFile);

  148.   Dispose(Data);

  150.   StretchFile:=0;
  151. end;

  153. end.
复制代码


--完--
回复

使用道具 举报

FlierMate_
发表于 4-3-2011 10:33 PM | 显示全部楼层
想在屏幕上显示比Turbo Pascal独有的WriteLn更快的字串？

我自编了DirectText。（记得Text Mode的内存地址是B800:0，所以直接写入内存就可以了）

  1. unit DirectText;
  2. {
  3.   DirectText Technology
  4.   Revision 1 (1997)
  5.   Developed by Boo Khan Ming

  7.   Enhance the text mode performance with direct video memory access.
  8. }

  10. interface

  12. procedure ChangeTextOffset(X,Y:byte);
  13. procedure ChangeTextRegion(X1,Y1,X2,Y2:byte);
  14. function RequestTextOffsetX:byte;
  15. function RequestTextOffsetY:byte;
  16. procedure ClearTextContent;
  17. procedure ChangeTextAppearance(OldColor,NewColor:byte);
  18. procedure InsertText(Content:string);
  19. procedure InsertNewText(Content:string);
  20. procedure InsertSingleText(Content:char);
  21. procedure InsertMultipleText(Content,Count:byte);
  22. procedure InsertNewMultipleText(Content,Count:byte);

  24. implementation

  26. uses CRT;

  28. const
  29.   TextContentLimitX=80;
  30.   TextContentLimitY=25;

  32. type
  33.   TextContentType=array [0..(TextContentLimitX*TextContentLimitX)-1] of word;

  35. var
  36.   TextContent:TextContentType absolute $b800:0;
  37.   TextContentOffsetX,TextContentOffsetY:byte;
  38.   TextContentLowerBoundX,TextContentLowerBoundY:byte;
  39.   TextContentUpperBoundX,TextContentUpperBoundY:byte;
  40.   CursorPosition:word absolute $0000:$0450;
  41.   Counter:byte;

  43. procedure AutoAdjustTextOffset;
  44. begin
  45.   if TextContentOffsetX<TextContentLowerBoundX then
  46.     TextContentOffsetX:=TextContentLowerBoundX;
  47.   if TextContentOffsetY<TextContentLowerBoundY then
  48.     TextContentOffsetY:=TextContentLowerBoundY;

  50.   if TextContentOffsetX>TextContentUpperBoundX then
  51.   begin
  52.     TextContentOffsetX:=TextContentLowerBoundX;
  53.     Inc(TextContentOffsetY);
  54.   end;

  56.   if TextContentOffsetY>TextContentUpperBoundY then
  57.     TextContentOffsetY:=TextContentUpperBoundY;
  58. {
  59.   asm
  60.     mov  ah, 02h
  61.     xor  bh, bh
  62.     mov  dh, TextContentOffsetY-1
  63.     mov  dl, TextContentOffsetX-1
  64.     int  10h
  65.   end;
  66. }
  67. {  CursorPosition:=(TextContentOffsetX shl 8)+TextContentOffsetY;}
  68. {  GotoXY(TextContentOffsetX,TextContentOffsetY);}
  69. end;

  71. procedure ChangeTextOffset(X,Y:byte);
  72. begin
  73.   TextContentOffsetX:=TextContentLowerBoundX+X-1;
  74.   TextContentOffsetY:=TextContentLowerBoundY+Y-1;

  76.   GotoXY(TextContentOffsetX,TextContentOffsetY);
  77. end;

  79. procedure ChangeTextRegion(X1,Y1,X2,Y2:byte);
  80. begin
  81.   TextContentLowerBoundX:=X1;
  82.   TextContentLowerBoundY:=Y1;
  83.   TextContentUpperBoundX:=X2;
  84.   TextContentUpperBoundY:=Y2;

  86.   TextContentOffsetX:=TextContentLowerBoundX;
  87.   TextContentOffsetY:=TextContentLowerBoundY;
  88. end;

  90. function RequestTextOffsetX:byte;
  91. begin
  92.   RequestTextOffsetX:=TextContentOffsetX;
  93. end;

  95. function RequestTextOffsetY:byte;
  96. begin
  97.   RequestTextOffsetY:=TextContentOffsetY;
  98. end;

  100. procedure ClearTextContent;
  101. var
  102.   CounterX,CounterY:byte;

  104. begin
  105.   for CounterX:=TextContentLowerBoundX to TextContentUpperBoundX do
  106.     for CounterY:=TextContentLowerBoundY to TextContentUpperBoundY do
  107.       TextContent[(CounterY-1)*TextContentLimitX+CounterX-1]:=255+TextAttr shl 8;
  108. end;

  110. procedure ChangeTextAppearance(OldColor,NewColor:byte);
  111. var
  112.   Counter:word;

  114. begin
  115.   Counter:=1;

  117.   repeat
  118.     if (Mem[$b800:Counter] and $f0)=(OldColor shl 4) then
  119.       Mem[$b800:Counter]:=(Mem[$b800:Counter] and $0f) or (NewColor shl 4);

  121.     Inc(Counter,2);
  122.   until Counter>4000;
  123. end;

  125. procedure InsertText(Content:string);
  126. begin
  127.   for Counter:=1 to Length(Content) do
  128.   begin
  129.     TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content[Counter])+TextAttr shl 8;

  131.     Inc(TextContentOffsetX);
  132.     AutoAdjustTextOffset;
  133.   end;
  134. end;

  136. procedure InsertNewText(Content:string);
  137. begin
  138.   for Counter:=1 to Length(Content) do
  139.   begin
  140.     TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content[Counter])+TextAttr shl 8;

  142.     Inc(TextContentOffsetX);
  143.     AutoAdjustTextOffset;
  144.   end;

  146.   TextContentOffsetX:=TextContentLowerBoundX;
  147.   Inc(TextContentOffsetY);
  148.   AutoAdjustTextOffset;
  149. end;

  151. procedure InsertSingleText(Content:char);
  152. begin
  153.   TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content)+TextAttr shl 8;

  155.   Inc(TextContentOffsetX);
  156.   AutoAdjustTextOffset;
  157. end;

  159. procedure InsertMultipleText(Content,Count:byte);
  160. begin
  161.   for Counter:=1 to Count do
  162.   begin
  163.     TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content)+TextAttr shl 8;

  165.     Inc(TextContentOffsetX);
  166.     AutoAdjustTextOffset;
  167.   end;
  168. end;

  170. procedure InsertNewMultipleText(Content,Count:byte);
  171. begin
  172.   for Counter:=0 to Count do
  173.   begin
  174.     TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content)+TextAttr shl 8;

  176.     Inc(TextContentOffsetX);
  177.     AutoAdjustTextOffset;
  178.   end;

  180.   TextContentOffsetX:=TextContentLowerBoundX;
  181.   Inc(TextContentOffsetY);
  182.   AutoAdjustTextOffset;
  183. end;

  185. begin
  186.   TextContentLowerBoundX:=1;
  187.   TextContentLowerBoundY:=1;
  188.   TextContentUpperBoundX:=TextContentLimitX;
  189.   TextContentUpperBoundY:=TextContentLimitY;

  191.   TextContentOffsetX:=TextContentLowerBoundX;
  192.   TextContentOffsetY:=TextContentLowerBoundY;
  193. end.
复制代码
回复

使用道具 举报

FlierMate_
发表于 4-3-2011 11:06 PM | 显示全部楼层
回复 9# FlierMate_


    不过实不相瞒，这套自创压缩原理分分钟有可能不是压缩文件，而是扩展文件(Negative Compression)使到压缩后的文件比原有的文件更大。见笑了，没有商业用途。

   除了分享外，我希望版主不要删除此帖，因为将来万一在互联网搜索不到自己的源代码，这里还可以作为备份。（我自己不想收藏）

谢谢各位。
回复

使用道具 举报

chrizyuen2
发表于 5-3-2011 12:43 AM | 显示全部楼层
发去sourceforge不行么？
回复

使用道具 举报

FlierMate_
发表于 5-3-2011 01:09 AM | 显示全部楼层
发去sourceforge不行么？
chrizyuen2 发表于 5-3-2011 12:43 AM


     可以么？不是Linux那些才发去那边的吗？（难道DOS也可以？）
回复

使用道具 举报

chrizyuen2
发表于 5-3-2011 01:17 AM | 显示全部楼层
可以么？不是Linux那些才发去那边的吗？（难道DOS也可以？）
FlierMate_ 发表于 5-3-2011 01:09 AM


当然可以
回复

使用道具 举报

FlierMate_
发表于 5-3-2011 01:19 AM | 显示全部楼层
回复 15# chrizyuen2


    哗！太好了。谢谢！
回复

使用道具 举报


ADVERTISEMENT

FlierMate_
发表于 5-3-2011 02:02 AM | 显示全部楼层
当然可以
chrizyuen2 发表于 5-3-2011 01:17 AM



    还是不要了，主要原因是我不要再提供源代码上的支持了。
回复

使用道具 举报

aquamax
发表于 11-3-2011 03:13 PM | 显示全部楼层
PASCAL.......想当年......
(下删50000字)
...
回复

使用道具 举报

FlierMate__
发表于 13-3-2011 08:49 AM | 显示全部楼层
PASCAL.......想当年......
(下删50000字)
...
aquamax 发表于 11-3-2011 03:13 PM



    如果你不知道，另外有人写了FreePascal, Virtual Pascal都很不错。
回复

使用道具 举报

aquamax
发表于 14-3-2011 04:22 PM | 显示全部楼层
COBOL有做过吗?
现在的MARKET都是.NET/JAVA的了....
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

 

所属分类: 电脑手机


ADVERTISEMENT


本周最热论坛帖子本周最热论坛帖子

ADVERTISEMENT


佳礼网 面子书


ADVERTISEMENT

ADVERTISEMENT


版权所有 © 1996-2023 Cari Internet Sdn Bhd (483575-W)|IPSERVERONE 提供云主机|广告刊登|关于我们|私隐权|免控|投诉|联络|脸书|佳礼资讯网

GMT+8, 14-11-2025 05:09 PM , Processed in 0.150173 second(s), 24 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表