谁要.PAS源代码？

FlierMate. · 发表于 4-3-2011 07:32 AM

本帖最后由 FlierMate. 于 4-3-2011 01:51 PM 编辑

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

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

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

FlierMate. · 发表于 4-3-2011 06:19 PM

这里有一个示例：

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

压缩：

{
File Packer
Programmed by Boo Khan Ming
E-mail: bookm@tm.net.my
WWW: http://www.geocities.com/SiliconValley/Horizon/3409/
This program was initially written in 1995.8.21
Revised in 1999.6.20
--------------------------------------------------------------------------
This program compresses plain text file only, by stripping off the highest
unused bit, that is, 8-bit character is truncated to 7-bit character,
since the highest bit is unused for plain text (ASCII below 128).
During the packing, every 8 bytes is compact to 7 bytes, as the highest
unused bit of every 7 bytes exactly fit another 7-bit character.
This method of compression always saves 12.5% (1/8).
Works on plain text file only.
}
var
OutputFileName,InputFileName:string;
InputFile,OutputFile:file of byte;
InputCode,OutputCode:byte;
Done:boolean;
Counter:byte;
begin
WriteLn('File Packer');
WriteLn('Developed by Boo Khan Ming');
WriteLn;
if ParamCount<>2 then
begin
WriteLn('Usage: PACK <input filename> <output filename>');
Halt(255);
end;
InputFileName:=ParamStr(1);
OutputFileName:=ParamStr(2);
{$I-}
Assign(InputFile,InputFileName);
Reset(InputFile);
{$I+}
if IOResult<>0 then
begin
WriteLn('Unable to open input file.');
Halt(1);
end;
{$I-}
Assign(OutputFile,OutputFileName);
Rewrite(OutputFile);
{$I+}
if IOResult<>0 then
begin
WriteLn('Unable to create output file.');
Halt(2);
end;
Done:=False;
repeat
Read(InputFile,InputCode);
if EOF(InputFile) then
Done:=True
else
begin
{ Shift off leftmost unused bit }
InputCode:=InputCode shl 1;
for Counter:=0 to 6 do
begin
if EOF(InputFile) then
begin
OutputCode:=0;
Done:=True;
end
else
begin
Read(InputFile,OutputCode);
{ Turn off top bit }
OutputCode:=OutputCode and 127;
{ Pack bit }
OutputCode:=OutputCode or ((InputCode shl Counter) and 128);
Write(OutputFile,OutputCode);
end;
end;
end;
until Done;
Close(InputFile);
Close(OutputFile);
end.

复制代码

解压缩：

{
File Depacker
Programmed by Boo Khan Ming
E-mail: bookm@tm.net.my
WWW: http://www.geocities.com/SiliconValley/Horizon/3409/
This program was initially written in 1995.8.21
Revised in 1999.6.20
--------------------------------------------------------------------------
This program compresses plain text file only, by stripping off the highest
unused bit, that is, 8-bit character is truncated to 7-bit character,
since the highest bit is unused for plain text (ASCII below 128).
During the packing, every 8 bytes is compact to 7 bytes, as the highest
unused bit of every 7 bytes exactly fit another 7-bit character.
This method of compression always saves 12.5% (1/8).
Works on plain text file only.
}
var
OutputFileName,InputFileName:string;
InputFile,OutputFile:file of byte;
InputCode,OutputCode:byte;
Done:boolean;
Counter:byte;
ByteArray:array [1..7] of byte;
begin
WriteLn('File Depacker');
WriteLn('Developed by Boo Khan Ming');
WriteLn;
if ParamCount<>2 then
begin
WriteLn('Usage: DEPACK <input filename> <output filename>');
Halt(255);
end;
InputFileName:=ParamStr(1);
OutputFileName:=ParamStr(2);
{$I-}
Assign(InputFile,InputFileName);
Reset(InputFile);
{$I+}
if IOResult<>0 then
begin
WriteLn('Unable to open input file.');
Halt(1);
end;
{$I-}
Assign(OutputFile,OutputFileName);
Rewrite(OutputFile);
{$I+}
if IOResult<>0 then
begin
WriteLn('Unable to create output file.');
Halt(2);
end;
Done:=False;
repeat
InputCode:=0;
for Counter:=1 to 7 do
begin
if EOF(InputFile) then
Done:=True
else
begin
Read(InputFile,OutputCode);
{ Turn off top bit }
ByteArray[Counter]:=OutputCode and 127;
{ Clear lower bit and depack bit }
OutputCode:=(OutputCode and 128) shr Counter;
{ Build up the 8th byte }
InputCode:=InputCode or OutputCode;
end;
end;
Write(OutputFile,InputCode);
for Counter:=1 to 7 do
Write(OutputFile,ByteArray[Counter]);
until Done;
Close(InputFile);
Close(OutputFile);
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)。

unit Sound;
{
Sound Service Unit
Revision 2 (1997-1998)
Developed by Boo Khan Ming
Provide direct access to Sound Blaster compatible sound card.
Featuring hardware diagnostic, full control of mixer settings and various
recording preferences.
Support sample playing and recording.
}
interface
const
DirectSoundFormatID='DLS';
Mic=0;
CD=1;
Line=3;
type
DirectSoundFormatType=record
ID:string[3];
Version:word;
Description:string;
HardwareRevision:word;
Frequency:word;
MasterVolume:word;
VoiceVolume:word;
end;
var
MasterSignal,SlaveSignal:boolean;
VoicePointer,VoiceLength:longint;
RecordLength:word;
SoundCardBasePort:word;
DirectSoundFormat:DirectSoundFormatType;
function AutoDetectSoundCard(var BasePort:word):boolean;
procedure ResetDSP;
procedure OutputDataDSP(Data:byte);
function InputDataDSP:byte;
procedure CheckDSPVersion(var Major,Minor:byte);
function CheckSoundCardType:string;
procedure NewTimerHandler; interrupt;
procedure ChangeTimerFrequency(Frequency:word);
procedure StartTimerHandler(NewVector:pointer;Frequency:word);
procedure RestoreTimerHandler;
procedure ResetVolumeSettings;
procedure ChangeMasterVolume(Left,Right:byte);
procedure ChangeVoiceVolume(Left,Right:byte);
procedure ChangeMIDIVolume(Left,Right:byte);
procedure ChangeCDVolume(Left,Right:byte);
procedure ChangeLineVolume(Left,Right:byte);
procedure ChangeMicVolume(Balance:byte);
procedure CheckMasterVolume(var Left,Right:byte);
procedure CheckVoiceVolume(var Left,Right:byte);
procedure CheckMIDIVolume(var Left,Right:byte);
procedure CheckCDVolume(var Left,Right:byte);
procedure CheckLineVolume(var Left,Right:byte);
procedure CheckMicVolume(var Balance:byte);
procedure SelectVoiceInput(Source:byte);
procedure EnableInputFilter;
procedure DisableInputFilter;
procedure EnableOutputFilter;
procedure DisableOutputFilter;
procedure SelectStereoOutput;
procedure SelectMonoOutput;
procedure SelectHighPassFilter;
procedure SelectLowPassFilter;
procedure ChangeSamplingRate(Rate:longint);
function PrepareRecordVoice:boolean;
procedure ShutRecordVoice;
procedure RecordVoice;
procedure PlayVoice;
function SaveVoice(FileName:string;Description:string):boolean;
function OpenVoice(FileName:string;Manual:boolean;var Description:string):boolean;
implementation
uses DOS,Swap,Mouse,Error;
const
TemporaryVector=100;
ResetRegister=$06;
ReadDataRegister=$0a;
WriteCommandRegister=$0c;
WriteBufferRegister=$0c;
DataAvailableRegister=$0e;
ChannelRegister=$02;
MasterRegister=$22;
VoiceRegister=$04;
MIDIRegister=$26;
CDRegister=$28;
LineRegister=$2e;
MicRegister=$0a;
var
Counter:word;
VoiceData:byte;
DirectSoundFile:file of byte;
function AutoDetectSoundCard(var BasePort:word):boolean;
const
RetryTime1=10;
RetryTime2=100;
var
Counter1,Counter2:word;
Found:boolean;
begin
BasePort:=$210;
Found:=False;
Counter1:=RetryTime1;
while (BasePort<=$260) and (not Found) do
begin
Port[BasePort+ResetRegister]:=1;
Port[BasePort+ResetRegister]:=0;
while (Counter2>RetryTime2) and (Port[BasePort+DataAvailableRegister]<128) do
Dec(Counter2);
if (Counter2=0) or (Port[BasePort+$a]<>$aa) then
begin
Dec(Counter1);
if Counter1=0 then
begin
Counter1:=RetryTime1;
BasePort:=BasePort+$10;
end;
end
else
begin
Found:=True;
SoundCardBasePort:=BasePort;
end;
end;
AutoDetectSoundCard:=Found;
end;
procedure ResetDSP;
begin
Port[SoundCardBasePort+ResetRegister]:=1;
Port[SoundCardBasePort+ResetRegister]:=0;
while (Port[SoundCardBasePort+DataAvailableRegister] and 128)=0 do;
while not (Port[SoundCardBasePort+ReadDataRegister]=$aa) do;
end;
procedure OutputDataDSP(Data:byte);
begin
while (Port[SoundCardBasePort+WriteBufferRegister] and 128)<>0 do;
Port[SoundCardBasePort+WriteCommandRegister]:=Data;
end;
function InputDataDSP:byte;
begin
while (Port[SoundCardBasePort+DataAvailableRegister] and 128)=0 do;
InputDataDSP:=Port[SoundCardBasePort+ReadDataRegister];
end;
procedure CheckDSPVersion(var Major,Minor:byte);
begin
OutputDataDSP($e1);
Major:=InputDataDSP;
Minor:=InputDataDSP;
end;
function CheckSoundCardType:string;
var
Major,Minor:byte;
begin
CheckDSPVersion(Major,Minor);
case Major of
1:CheckSoundCardType:='Sound Blaster';
2:CheckSoundCardType:='Sound Blaster Pro';
else
CheckSoundCardType:='Sound Blaster 16';
end;
end;
procedure ChangeTimerFrequency(Frequency:word);
var
Counter:word;
begin
Inline($fa);
Counter:=1193180 div Frequency;
Port[$43]:=$36;
Port[$40]:=Lo(Counter);
Port[$40]:=Hi(Counter);
Inline($fb);
DirectSoundFormat.Frequency:=Frequency;
end;
procedure StartTimerHandler(NewVector:pointer;Frequency:word);
var
OldVector:pointer;
begin
Inline($fa);
GetIntVec(8,OldVector);
SetIntVec(TemporaryVector,OldVector);
SetIntVec(8,NewVector);
ChangeTimerFrequency(Frequency);
Inline($fb);
end;
procedure RestoreTimerHandler;
var
OldVector:pointer;
begin
Inline($fa);
Port[$43]:=$36;
Port[$40]:=0;
Port[$40]:=0;
GetIntVec(TemporaryVector,OldVector);
SetIntVec(8,OldVector);
Inline($fb);
end;
procedure NewTimerHandler; {interrupt;}
var
Register:Registers;
begin
Dec(Counter);
if Counter=0 then
begin
Intr(TemporaryVector,Register);
Counter:=100 div 18;
end
else
Port[$20]:=$20;
MasterSignal:=not MasterSignal;
end;
procedure ResetVolumeSettings;
begin
Port[SoundCardBasePort+$04]:=0;
Port[SoundCardBasePort+$05]:=0;
end;
procedure ChangeVolumeSettings(Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=ChannelRegister;
Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
end;
procedure ChangeMasterVolume(Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=MasterRegister;
Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
end;
procedure ChangeVoiceVolume(Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=VoiceRegister;
Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
end;
procedure ChangeMIDIVolume(Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=MIDIRegister;
Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
end;
procedure ChangeCDVolume(Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=CDRegister;
Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
end;
procedure ChangeLineVolume(Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=LineRegister;
Port[SoundCardBasePort+$05]:=(Left shl 4)+Right;
end;
procedure ChangeMicVolume(Balance:byte);
begin
Port[SoundCardBasePort+$04]:=MicRegister;
Port[SoundCardBasePort+$05]:=Balance;
end;
procedure CheckMasterVolume(var Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=MasterRegister;
Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
Right:=Port[SoundCardBasePort+$05] and $0f;
end;
procedure CheckVoiceVolume(var Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=VoiceRegister;
Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
Right:=Port[SoundCardBasePort+$05] and $0f;
end;
procedure CheckMIDIVolume(var Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=MIDIRegister;
Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
Right:=Port[SoundCardBasePort+$05] and $0f;
end;
procedure CheckCDVolume(var Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=CDRegister;
Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
Right:=Port[SoundCardBasePort+$05] and $0f;
end;
procedure CheckLineVolume(var Left,Right:byte);
begin
Port[SoundCardBasePort+$04]:=LineRegister;
Left:=(Port[SoundCardBasePort+$05] and $f0) shr 4;
Right:=Port[SoundCardBasePort+$05] and $0f;
end;
procedure CheckMicVolume(var Balance:byte);
begin
Port[SoundCardBasePort+$04]:=MicRegister;
Balance:=Port[SoundCardBasePort+$05];
end;
procedure SelectVoiceInput(Source:byte);
begin
Port[SoundCardBasePort+$04]:=$0c;
Port[SoundCardBasePort+$05]:=(Port[SoundCardBasePort+$05] and (not 7)) or ((Source shl 1) and 7);
end;
procedure EnableInputFilter;
begin
Port[SoundCardBasePort+$04]:=$0c;
Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or 32;
end;
procedure DisableInputFilter;
begin
Port[SoundCardBasePort+$04]:=$0c;
Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or (not 32);
end;
procedure EnableOutputFilter;
begin
Port[SoundCardBasePort+$04]:=$0e;
Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or 64;
end;
procedure DisableOutputFilter;
begin
Port[SoundCardBasePort+$04]:=$0e;
Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or (not 64);
end;

复制代码

待续……。

FlierMate. · 发表于 4-3-2011 06:29 PM

procedure SelectStereoOutput;
begin
Port[SoundCardBasePort+$04]:=$0e;
Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or 2;
end;
procedure SelectMonoOutput;
begin
Port[SoundCardBasePort+$04]:=$0e;
Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or (not 2);
end;
procedure SelectHighPassFilter;
begin
Port[SoundCardBasePort+$04]:=$0c;
Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or 8;
end;
procedure SelectLowPassFilter;
begin
Port[SoundCardBasePort+$04]:=$0c;
Port[SoundCardBasePort+$05]:=Port[SoundCardBasePort+$05] or (not 8);
end;
procedure ChangeSamplingRate(Rate:longint);
begin
Port[SoundCardBasePort+WriteBufferRegister]:=$40;
repeat until Port[SoundCardBasePort+WriteBufferRegister]<128;
Port[SoundCardBasePort+WriteBufferRegister]:=Round(256-1000000/Rate);
end;
function PrepareRecordVoice:boolean;
begin
DefineDefaultSwapFile('SOUND.SWP');
if EstablishVirtualMemory(ByteType,60*4*1024*RecordLength,1)<>0 then
begin
PrepareRecordVoice:=False;
Exit;
end;
PrepareRecordVoice:=True;
end;
procedure ShutRecordVoice;
begin
DisposeVirtualMemory;
VoicePointer:=0;
VoiceLength:=0;
end;
procedure RecordVoice;
begin
VoicePointer:=0;
repeat
Port[SoundCardBasePort+WriteBufferRegister]:=$20;
repeat until Port[SoundCardBasePort+DataAvailableRegister]>=128;
EnterDataByte(0,VoicePointer,Port[SoundCardBasePort+ReadDataRegister]);
Inc(VoicePointer);
repeat until SlaveSignal=not MasterSignal;
SlaveSignal:=MasterSignal;
if GetMouseEvent<>0 then
Break;
until VoicePointer>=(60*4*1024*RecordLength);
VoiceLength:=VoicePointer;
repeat until GetMouseEvent=0;
end;
procedure PlayVoice;
begin
VoicePointer:=0;
repeat
Port[SoundCardBasePort+WriteBufferRegister]:=$10;
repeat until Port[SoundCardBasePort+WriteBufferRegister]<128;
Port[SoundCardBasePort+WriteBufferRegister]:=EnquireDataByte(0,VoicePointer);
Inc(VoicePointer);
repeat until SlaveSignal=not MasterSignal;
SlaveSignal:=MasterSignal;
if GetMouseEvent<>0 then
Break;
until VoicePointer>=VoiceLength;
repeat until GetMouseEvent=0;
end;
function SaveVoice(FileName:string;Description:string):boolean;
var
Major,Minor:byte;
Left,Right:byte;
Counter:word;
begin
SaveVoice:=False;
VoicePointer:=0;
{$I-}
Assign(DirectSoundFile,FileName);
Rewrite(DirectSoundFile);
{$I+}
if IOResult<>0 then
Exit;
CheckDSPVersion(Major,Minor);
DirectSoundFormat.ID:=DirectSoundFormatID;
DirectSoundFormat.Version:=(1 shl 8) or (0);
DirectSoundFormat.HardwareRevision:=(Major shl 8) or (Minor);
DirectSoundFormat.Description:=Description;
CheckMasterVolume(Left,Right);
DirectSoundFormat.MasterVolume:=(Left shl 8) or Right;
CheckVoiceVolume(Left,Right);
DirectSoundFormat.VoiceVolume:=(Left shl 8) or Right;
{$I-}
for Counter:=1 to 3 do
begin
VoiceData:=Ord(DirectSoundFormat.ID[Counter]);
Write(DirectSoundFile,VoiceData);
end;
VoiceData:=Hi(DirectSoundFormat.Version);
Write(DirectSoundFile,VoiceData);
VoiceData:=Lo(DirectSoundFormat.Version);
Write(DirectSoundFile,VoiceData);
for Counter:=1 to 255 do
begin
VoiceData:=Ord(DirectSoundFormat.Description[Counter]);
Write(DirectSoundFile,VoiceData);
end;
VoiceData:=Hi(DirectSoundFormat.HardwareRevision);
Write(DirectSoundFile,VoiceData);
VoiceData:=Lo(DirectSoundFormat.HardwareRevision);
Write(DirectSoundFile,VoiceData);
VoiceData:=Hi(DirectSoundFormat.Frequency);
Write(DirectSoundFile,VoiceData);
VoiceData:=Lo(DirectSoundFormat.Frequency);
Write(DirectSoundFile,VoiceData);
VoiceData:=Hi(DirectSoundFormat.MasterVolume);
Write(DirectSoundFile,VoiceData);
VoiceData:=Lo(DirectSoundFormat.MasterVolume);
Write(DirectSoundFile,VoiceData);
VoiceData:=Hi(DirectSoundFormat.VoiceVolume);
Write(DirectSoundFile,VoiceData);
VoiceData:=Lo(DirectSoundFormat.VoiceVolume);
Write(DirectSoundFile,VoiceData);
repeat
VoiceData:=EnquireDataByte(0,VoicePointer);
Inc(VoicePointer);
Write(DirectSoundFile,VoiceData);
until VoicePointer>=VoiceLength;
Close(DirectSoundFile);
{$I+}
if IOResult<>0 then
Exit;
SaveVoice:=True;
end;
function OpenVoice(FileName:string;Manual:boolean;var Description:string):boolean;
var
Counter:word;
begin
OpenVoice:=False;
VoicePointer:=0;
{$I-}
Assign(DirectSoundFile,FileName);
Reset(DirectSoundFile);
{$I+}
if IOResult<>0 then
Exit;
{$I-}
for Counter:=1 to 3 do
begin
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.ID:=DirectSoundFormat.ID+Chr(VoiceData);
end;
if DirectSoundFormat.ID<>DirectSoundFormatID then
Exit;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.Version:=VoiceData shl 8;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.Version:=DirectSoundFormat.Version or VoiceData;
Description:='';
for Counter:=1 to 255 do
begin
Read(DirectSoundFile,VoiceData);
Description:=Description+Chr(VoiceData);
end;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.HardwareRevision:=VoiceData shl 8;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.HardwareRevision:=DirectSoundFormat.Version or VoiceData;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.Frequency:=VoiceData shl 8;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.Frequency:=DirectSoundFormat.Version or VoiceData;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.MasterVolume:=VoiceData shl 8;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.MasterVolume:=DirectSoundFormat.Version or VoiceData;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.VoiceVolume:=VoiceData shl 8;
Read(DirectSoundFile,VoiceData);
DirectSoundFormat.VoiceVolume:=DirectSoundFormat.Version or VoiceData;
if not Manual then
begin
ChangeTimerFrequency(DirectSoundFormat.Frequency);
{if Hi(DirectSoundFormat.HardwareRevision)>=2 then
begin
ChangeMasterVolume(Hi(DirectSoundFormat.MasterVolume),Lo(DirectSoundFormat.MasterVolume));
ChangeVoiceVolume(Hi(DirectSoundFormat.VoiceVolume),Lo(DirectSoundFormat.VoiceVolume));
end;}
end;
repeat
Read(DirectSoundFile,VoiceData);
EnterDataByte(0,VoicePointer,VoiceData);
Inc(VoicePointer);
until (VoicePointer>=(60*4*1024*RecordLength)) or (EOF(DirectSoundFile));
VoiceLength:=VoicePointer;
Close(DirectSoundFile);
{$I+}
if IOResult<>0 then
Exit;
OpenVoice:=True;
end;
begin
SoundCardBasePort:=$220;
RecordLength:=5;
end.

复制代码

-完-

FlierMate. · 发表于 4-3-2011 06:43 PM

接下来，这是我自创的影像播放（没有采用压缩）的320x200x256格式。

影像播放模块：

unit Movie;
{
Direct Loading Video Service Unit
Revision 1997-1999
Researched and Developed Boo Khan Ming
Provide necessary code to display video at resolution of 320x200x256
consistently at predefined frame rate.
Video format established:
0-2 Video Format ID String (DLV)
3-4 Video Format Version Number
5-8 Total Frame
9-12 Frame Size (include palette)
13-14 Frame Rate (fps)
15- DLP Picture (without header)
DLV Version 1.0
DLV Version 1.1 Added long description
Added reserved space
DLV Version 1.2 Dynamic video size supported
Downward (not necessary fixed at 320x200)
compatible
with DLV 1.1
.................
Unit Version 2.0 Total frame actual count supported
Unit Version 2.2 Enabled user frame rate
Unit Version 2.4 Reversed video playback supported
Optimized video playback performance
(reduced palette reprogramme jerky effect)
Unit Version 2.5 Significantly better video playback performance
by preloading video data to extended memory (XMS)
}
interface
type
VidHeaderRef=record
VidID:string[3];
VidVer:word;
Description:string;
Reserved:string[251];
Width:word;
Height:word;
TotalFrame:longint;
FrameSize:longint;
FrameRate:word;
end;
procedure PrepareVideo;
procedure ShutVideo;
function OpenVideo(Filename:string):byte;
procedure CloseVideo;
function SeekFrame(Offset:longint):boolean;
function LoadVideo:byte;
procedure UnloadVideo;
function PlayVideo(Mode:byte;UserFrameRate:word):boolean;
function ReverseVideo(Mode:byte;UserFrameRate:word):boolean;
function StepVideo(Mode:byte;StepRatio:word;UserFrameRate:word):boolean;
function DiagnosticVideo(Mode:byte;StepRatio:word;var FrameRate:real;var Frame:longint):boolean;
implementation
uses CRT,DOS,Video,Mouse,Palette,Memory;
const
VidIDRef:string[3]='DLV';
type
VidPicRef=record
PicPal:array [1..768] of byte;
Pic:array [1..64000] of byte;
end;
var
f:file;
r:registers;
l,c:longint;
Size:word;
VidPic:^VidPicRef;
VidHeader:VidHeaderRef;
VidHandle:word;
AdvancedPlayback:boolean;
procedure PrepareVideo;
begin
{ prepare low resolution graphics screen }
asm
mov ax, 0013h
int 10h
end;
end;
procedure ShutVideo;
begin
TextMode(co80);
end;
function SeekFrame(Offset:longint):boolean;
var
PalOfs:word;
PicSeg,PicOfs:word;
Width,Height:word;
VidOfs:longint;
begin
SeekFrame:=False;
if AdvancedPlayback then
begin
VidOfs:=Offset-SizeOf(VidHeader);
TransferEMB(Longint(@VidPic^),0,VidOfs,VidHandle,VidHeader.FrameSize);
if XMSError<>0 then
begin
Exit;
end;
end
else
begin
{$I-}
Seek(f,Offset);
BlockRead(f,VidPic^,VidHeader.FrameSize);
{$I+}
if IOResult<>0 then
Exit;
end;
PalOfs:=Ofs(VidPic^.PicPal);
PicSeg:=Seg(VidPic^.Pic);
PicOfs:=Ofs(VidPic^.Pic);
Width:=VidHeader.Width;
Height:=VidHeader.Height;
if ((Width=320) and (Height=200))
or (VidHeader.VidVer<$0120) then
begin
asm
mov ax, 1012h
xor bx, bx
mov cx, 256
mov dx, PalOfs
int 10h
push ds
mov ax, 0a000h
mov es, ax
mov ax, PicSeg
mov ds, ax
xor di, di
mov si, PicOfs
mov cx, 32000
rep movsw
pop ds
end;
end
else
begin
asm
mov ax, 1012h
xor bx, bx
mov cx, 256
mov dx, PalOfs
int 10h
push ds
mov ax, 0a000h
mov es, ax
mov ax, PicSeg
mov ds, ax
xor di, di
mov si, PicOfs
mov cx, Height
@Draw:
push cx
mov cx, Width
rep movsb
add di, 320
sub di, Width
pop cx
dec cx
jnz @Draw
pop ds
end;
end;
SeekFrame:=True;
end;
function OpenVideo(Filename:string):byte;
{
Error codes: 0=Successful
1=Insufficient memory
2=File open error
3=Invalid video format
255=Undefined error
}
begin
OpenVideo:=255;
AdvancedPlayback:=False;
{ determine available memory }
if MaxAvail<SizeOf(VidPic^) then
begin
OpenVideo:=1;
Exit;
end;
{ create new dynamic variable }
New(VidPic);
{$I-}
Assign(f,Filename);
Reset(f,1);
BlockRead(f,VidHeader,SizeOf(VidHeader));
{$I+}
if IOResult<>0 then
begin
OpenVideo:=2;
Exit;
end;
if VidHeader.VidID<>VidIDRef then
begin
OpenVideo:=3;
Exit;
end;
OpenVideo:=0;
end;
procedure CloseVideo;
begin
{$I-}
Close(f);
{$I+}
{ dispose dynamic variable }
Dispose(VidPic);
end;
function LoadVideo:byte;
{
Error codes: 0=Successful
1=XMS driver not installed
2=Insufficient extended memory
3=Unable to allocate extended memory
4=Error encountered during video data transfer (loading)
255=Undefined error
}
var
Offset:longint;
begin
LoadVideo:=255;
AdvancedPlayback:=True;
if not XMSInstalled then
begin
LoadVideo:=1;
Exit;
end;
if EMBMaxAvail<(FileSize(f) div 1024) then
begin
LoadVideo:=2;
Exit;
end;
VidHandle:=AllocateEMB(FileSize(f) div 1024);
if XMSError<>0 then
begin
LoadVideo:=3;
Exit;
end;
Seek(f,SizeOf(VidHeader));
Offset:=0;
repeat
BlockRead(f,VidPic^,VidHeader.FrameSize,Size);
if Size<>0 then
begin
TransferEMB(Offset,VidHandle,Longint(@VidPic^),0,VidHeader.FrameSize);
Inc(Offset,VidHeader.FrameSize);
if XMSError<>0 then
begin
LoadVideo:=4;
Exit;
end;
end;
until (Size=0);
LoadVideo:=0;
end;
procedure UnloadVideo;
begin
FreeEMB(VidHandle);
end;
function PlayVideo(Mode:byte;UserFrameRate:word):boolean;
{
Modes: 0=Normal
1=Fast
2=Normal with UserFrameRate enabled
3=Fast with UserFrameRate enabled
}
var
VidPtr:longint;
begin
PlayVideo:=False;
for l:=1 to VidHeader.TotalFrame do
begin
VidPtr:=((l-1)*VidHeader.FrameSize)+SizeOf(VidHeader);
if not SeekFrame(VidPtr) then
Exit;
if Keypressed then
Exit;
if GetMouseEvent<>0 then
begin
repeat until GetMouseEvent=0;
{PlayVideo:=True;}
Exit;
end;
if Mode=0 then
Delay(1000 div VidHeader.FrameRate)
else if Mode=2 then
Delay(1000 div UserFrameRate);
end;
PlayVideo:=True;
end;
function ReverseVideo(Mode:byte;UserFrameRate:word):boolean;
{
Modes: 0=Normal
1=Fast
2=Normal with UserFrameRate enabled
3=Fast with UserFrameRate enabled
}
var
VidPtr:longint;
begin
ReverseVideo:=False;
for l:=VidHeader.TotalFrame downto 1 do
begin
VidPtr:=((l-1)*VidHeader.FrameSize)+SizeOf(VidHeader);
if not SeekFrame(VidPtr) then
Exit;
if Keypressed then
Exit;
if GetMouseEvent<>0 then
begin
repeat until GetMouseEvent=0;
Exit;
end;
if Mode=0 then
Delay(1000 div VidHeader.FrameRate)
else if Mode=2 then
Delay(1000 div UserFrameRate);
end;
ReverseVideo:=True;
end;
function StepVideo(Mode:byte;StepRatio:word;UserFrameRate:word):boolean;
{
Modes: 0=Normal
1=Fast
2=Normal with UserFrameRate enabled
3=Fast with UserFrameRate enabled
}
var
VidPtr:longint;
begin
StepVideo:=False;
l:=1;
repeat
VidPtr:=((l-1)*VidHeader.FrameSize)+SizeOf(VidHeader);
if not SeekFrame(VidPtr) then
Exit;
if Keypressed then
Exit;
if Mode=0 then
Delay(1000 div VidHeader.FrameRate)
else if Mode=2 then
Delay(1000 div UserFrameRate);
Inc(l,StepRatio);
until l>VidHeader.TotalFrame;
StepVideo:=True;
end;
function DiagnosticVideo(Mode:byte;StepRatio:word;var FrameRate:real;var Frame:longint):boolean;
{
Modes: 0=Normal
1=Fast
}
var
VidPtr:longint;
Hour,Min,Sec,Sec100:word;
OldMin,NewMin:word;
OldSec,NewSec:word;
FrameTick:real;
begin
DiagnosticVideo:=False;
repeat
GetTime(Hour,Min,Sec,Sec100);
until Sec100=0;
OldMin:=Min;
OldSec:=Sec;
FrameRate:=0;
Frame:=0;
l:=1;
repeat
VidPtr:=((l-1)*VidHeader.FrameSize)+SizeOf(VidHeader);
if not SeekFrame(VidPtr) then
Exit;
if Mode=0 then
Delay(1000 div VidHeader.FrameRate);
Inc(l,StepRatio);
Inc(Frame);
until l>VidHeader.TotalFrame;
GetTime(Hour,Min,Sec,Sec100);
NewMin:=Min;
NewSec:=Sec;
if NewMin<OldMin then
NewMin:=NewMin+60;
if Sec100=0 then
Sec100:=1;
{ compute frame rate using timer tick }
FrameTick:=((NewMin*60)+NewSec)-((OldMin*60)+OldSec)+(1/Sec100);
FrameRate:=VidHeader.TotalFrame/FrameTick;
DiagnosticVideo:=True;
end;
end.

复制代码

FlierMate. · 发表于 4-3-2011 06:46 PM

楼上的影像播放动用到内存模块（除了中断DOS Interrupt部分是采用别人的，其他都是自编的）：

{$G+}
unit Memory;
{
Memory Service Unit
Revision 1 (1998)
Developed by Boo Khan Ming
Provide all available functions and procedures to utilise the
XMS (Extended Memory), UMB (Upper Memory Block) and the heap.
The XMS interrupt call routines are based on external source.
}
interface
var
XMSHandler:pointer;
XMSInstalled:boolean;
XMSError:byte;
function ShrinkHeap:boolean;
procedure ExpandHeap;
procedure CopyMemory(Source,Destination,Count:word);
function DumpMemory(Segment,Offset:word):string;
function FindMemory(StartSegment,EndSegment:word;var FoundSegment,FoundOffset:word;FindString:string):boolean;
function GetXMSVersion:longint;
function RequestHMA(Size:word):boolean;
function ReleaseHMA:boolean;
function GlobalEnableA20:boolean;
function GlobalDisableA20:boolean;
function LocalEnableA20:boolean;
function LocalDisableA20:boolean;
function QueryA20:boolean;
function EMBMaxAvail:word;
function EMBMemAvail:word;
function AllocateEMB(Size:word):word;
function FreeEMB(Handle:word):boolean;
function TransferEMB(DestinationOffset:longint;DestinationHandle:word;
SourceOffset:longint;SourceHandle:word;
Count:longint):boolean;
function LockEMB(Handle:word):longint;
function UnlockEMB(Handle:word):boolean;
function GetEMBHandleInfo(Handle:word;var LockCount,FreeHandles:byte;var BlockSize:word):boolean;
function ReallocateEMB(Handle:word;NewSize:word):boolean;
function RequestUMB(Size:word):word;
function ReleaseUMB(Segment:word):boolean;
function UMBMemAvail:word;
implementation
function ShrinkHeap:boolean;
var
Size:word;
begin
Size:=MemW[Seg(HeapPtr):Ofs(HeapPtr)+2]-PrefixSeg+1;
asm
mov bx, Size
mov es, PrefixSeg
mov ah, 4ah
int 21h
jc @error
sub al, al
jmp @exit
@error:
mov al, 01h
@exit:
end;
end;
procedure ExpandHeap;
var
Size:word;
begin
Size:=MemW[Seg(HeapEnd):Ofs(HeapEnd)+2]-PrefixSeg;
asm
mov bx, Size
mov es, PrefixSeg
mov ah, 4ah
int 21h
end;
end;
procedure CopyMemory(Source,Destination,Count:word); assembler;
asm
push ds
mov ax, Source
mov ds, ax
mov ax, Destination
mov es, ax
xor si, si
xor di, di
mov cx, Count
rep movsw
pop ds
end;
function DumpMemory(Segment,Offset:word):string;
var
Scan:^byte;
Range:word;
Content:string;
begin
Range:=0;
Content:='';
repeat
Scan:=Ptr(Segment,Offset+Range);
if Scan^=0 then
Break;
Content:=Content+Chr(Scan^);
Inc(Range);
until Range>255;
DumpMemory:=Content;
end;
function FindMemory(StartSegment,EndSegment:word;var FoundSegment,FoundOffset:word;FindString:string):boolean;
var
Scan:^byte;
SegmentPtr,OffsetPtr:longint;
Counter:byte;
Found:boolean;
begin
FindMemory:=False;
Found:=False;
for SegmentPtr:=StartSegment to EndSegment do
begin
for OffsetPtr:=$0000 to $FFFF do
begin
Scan:=Ptr(SegmentPtr,OffsetPtr);
if UpCase(Chr(Scan^))=UpCase(FindString[1]) then
begin
for Counter:=1 to Length(FindString)-1 do
begin
Scan:=Ptr(SegmentPtr,OffsetPtr+Counter);
if UpCase(Chr(Scan^))<>UpCase(FindString[Counter+1]) then
begin
Found:=False;
Break;
end
else
Found:=True;
end;
end;
if Found then
Break;
end;
if Found then
Break;
end;
if Found then
begin
FindMemory:=True;
FoundSegment:=SegmentPtr;
FoundOffset:=OffsetPtr;
end;
end;
procedure XMSInterrupt; near; assembler;
asm
push SEG @DATA
pop es
cmp es:[XMSInstalled], 1
jnz @fail
call DWORD PTR es:[XMSHandler]
or ax, ax
jnz @success
push ds
push es
pop ds
mov XMSError, bl
pop ds
@fail:
xor ax, ax
@success:
end;
function GetXMSVersion:longint; assembler;
asm
xor ax, ax
xor dx, dx
sub ah, ah
call XMSInterrupt
xchg dx, bx
end;
function RequestHMA(Size:word):boolean; assembler;
asm
mov ah, 01h
call XMSInterrupt
end;
function ReleaseHMA:boolean; assembler;
asm
mov ah, 02h
call XMSInterrupt
end;
function GlobalEnableA20:boolean; assembler;
asm
mov ah, 03h
call XMSInterrupt
end;
function GlobalDisableA20:boolean; assembler;
asm
mov ah, 04h
call XMSInterrupt
end;
function LocalEnableA20:boolean; assembler;
asm
mov ah, 05h
call XMSInterrupt
end;
function LocalDisableA20:boolean; assembler;
asm
mov ah, 06h
call XMSInterrupt
end;
function QueryA20:boolean; assembler;
asm
mov ah, 07h
call XMSInterrupt
end;
function EMBMaxAvail:word; assembler;
asm
mov ah, 08h
call XMSInterrupt
end;
function EMBMemAvail:word; assembler;
asm
xor dx, dx
mov ah, 08h
call XMSInterrupt
mov ax, dx
end;
function AllocateEMB(Size:word):word; assembler;
asm
mov ah, 09h
mov dx, Size
call XMSInterrupt
or al, al
jz @finish
mov ax, dx
@finish:
end;
function FreeEMB(Handle:word):boolean; assembler;
asm
mov dx, Handle
mov ah, 0ah
call XMSInterrupt
end;
function TransferEMB(DestinationOffset:longint;DestinationHandle:word;
SourceOffset:longint;SourceHandle:word;
Count:longint):boolean;
begin
asm
push ds
push ss
pop ds
lea si, Count
mov ah, 0bh
call XMSInterrupt
mov @Result, al
pop ds
end
end;
function LockEMB(Handle:word):longint; assembler;
asm
mov ah, 0ch
mov dx, handle
call XMSInterrupt
mov ax, bx
end;
function UnlockEMB(Handle:word):boolean; assembler;
asm
mov ah, 0dh
mov dx, Handle
call XMSInterrupt
end;
function GetEMBHandleInfo(Handle:word;var LockCount,FreeHandles:byte;var BlockSize:word):boolean; assembler;
asm
mov dx, Handle
mov ah, 0eh
call XMSInterrupt
les di, LockCount
mov BYTE PTR es:[di], bh
les di, FreeHandles
mov BYTE PTR es:[di], bl
les di, BlockSize
mov WORD PTR es:[di], dx
end;
function ReallocateEMB(Handle:word;NewSize:word):boolean; assembler;
asm
mov ah, 0fh
mov bx, NewSize
mov dx, Handle
call XMSInterrupt
end;
function RequestUMB(Size:word):word; assembler;
asm
mov ah, 10h
mov dx, Size
call XMSInterrupt
mov ax, bx
end;
function ReleaseUMB(Segment:word):boolean; assembler;
asm
mov ah, 11h
mov dx, Segment
call XMSInterrupt
end;
function UMBMemAvail:word; assembler;
asm
mov ah, 10h
mov dx, 0ffffh
call XMSInterrupt
mov ax, dx
end;
begin
asm
mov ax, 4300h
int 2fh
cmp al, 80h
jnz @false
mov ax, 4310h
int 2fh
mov WORD PTR XMSHandler[0], bx
mov WORD PTR XMSHandler[2], es
mov XMSInstalled, 1
jmp @true
@false:
mov XMSInstalled, 0
@true:
end;
end.

复制代码

FlierMate. · 发表于 4-3-2011 06:49 PM

除此之外，也需要用到彩色盘（Palette）的模块。
256色减至16色的颜色处理是我自研的技术。

unit Palette;
{
Palette Service Unit
Revision 2 (1998-1999)
Developed by Boo Khan Ming
Provide access to the video color palette and color processing options.
}
interface
procedure SetPalette(PalReg,PalVal:byte);
procedure SetPalette256(Color,Red,Green,Blue:byte);
procedure GetPalette256(Color:byte;var Red,Green,Blue:byte);
procedure SetIntensity(Level:byte);
procedure GetIntensity;
procedure InvertGraphicsPalette;
procedure IncreaseBrightness;
procedure DecreaseBrightness;
function SimplifyColorComponent(Value:byte):byte;
function DecreaseColor256(Red,Green,Blue:byte):byte;
implementation
type
ColorType=record
Red,Green,Blue:byte;
end;
var
ColorTable:array [0..63] of ColorType;
VideoPal:array [0..255,0..2] of byte;
Color:byte;
Counter:word;
PalLevel:byte;
PalRedRatio,PalGreenRatio,PalBlueRatio:byte;
procedure SetPalette(PalReg,PalVal:byte); assembler;
asm
mov ax, 1000h
mov bl, PalReg
mov bh, PalVal
int 10h
end;
procedure SetPalette256(Color,Red,Green,Blue:byte); assembler;
asm
mov dx, 03c8h
mov al, Color
out dx, al
inc dx
mov al, Red
mov cl, 2
shr al, cl
out dx, al
mov al, Green
mov cl, 2
shr al, cl
out dx, al
mov al, Blue
mov cl, 2
shr al, cl
out dx, al
end;
procedure GetPalette256(Color:byte;var Red,Green,Blue:byte);
begin
Port[$03c7]:=Color;
Red:=Port[$03c9];
Green:=Port[$03c9];
Blue:=Port[$03c9];
end;
procedure SetIntensity(Level:byte);
begin
for Color:=0 to 63 do
SetPalette256(Color,ColorTable[Color].Red*Level div 63,
ColorTable[Color].Green*Level div 63,
ColorTable[Color].Blue*Level div 63);
end;
procedure GetIntensity;
begin
for Color:=0 to 63 do
GetPalette256(Color,ColorTable[Color].Red,ColorTable[Color].Green,ColorTable[Color].Blue);
end;
procedure InvertGraphicsPalette;
begin
for Counter:=0 to 255 do
begin
Port[$03c7]:=Counter;
VideoPal[Counter,0]:=Port[$03c9];
VideoPal[Counter,1]:=Port[$03c9];
VideoPal[Counter,2]:=Port[$03c9];
end;
for Counter:=0 to 255 do
begin
VideoPal[Counter,0]:=not VideoPal[Counter,0];
VideoPal[Counter,1]:=not VideoPal[Counter,1];
VideoPal[Counter,2]:=not VideoPal[Counter,2];
Port[$03c8]:=Counter;
Port[$03c9]:=VideoPal[Counter,0];
Port[$03c9]:=VideoPal[Counter,1];
Port[$03c9]:=VideoPal[Counter,2];
end;
end;
procedure IncreaseBrightness;
begin
for Counter:=0 to 255 do
begin
Port[$03c7]:=Counter;
VideoPal[Counter,0]:=Port[$03c9];
VideoPal[Counter,1]:=Port[$03c9];
VideoPal[Counter,2]:=Port[$03c9];
end;
for Counter:=0 to 255 do
begin
for PalLevel:=0 to 2 do
begin
if VideoPal[Counter,PalLevel]<63 then
Inc(VideoPal[Counter,PalLevel]);
end;
Port[$03c8]:=Counter;
Port[$03c9]:=VideoPal[Counter,0];
Port[$03c9]:=VideoPal[Counter,1];
Port[$03c9]:=VideoPal[Counter,2];
end;
end;
procedure DecreaseBrightness;
begin
for Counter:=0 to 255 do
begin
Port[$03c7]:=Counter;
VideoPal[Counter,0]:=Port[$03c9];
VideoPal[Counter,1]:=Port[$03c9];
VideoPal[Counter,2]:=Port[$03c9];
end;
for Counter:=0 to 255 do
begin
for PalLevel:=0 to 2 do
begin
if VideoPal[Counter,PalLevel]>0 then
Dec(VideoPal[Counter,PalLevel]);
end;
Port[$03c8]:=Counter;
Port[$03c9]:=VideoPal[Counter,0];
Port[$03c9]:=VideoPal[Counter,1];
Port[$03c9]:=VideoPal[Counter,2];
end;
end;
function SimplifyColorComponent(Value:byte):byte;
begin
if Value>=52 then
SimplifyColorComponent:=63
else
if Value>=32 then
SimplifyColorComponent:=42
else
if Value>=12 then
SimplifyColorComponent:=21
else
SimplifyColorComponent:=0;
end;
function DecreaseColor256(Red,Green,Blue:byte):byte;
const
Palette16:array [0..15,1..3] of byte=((0,0,0),(0,0,42),(0,42,0),(0,42,42),
(42,0,0),(42,0,42),(42,42,0),(42,42,42),
(0,0,21),(0,0,63),(0,42,21),(0,42,63),
(42,0,21),(42,0,63),(42,42,21),(42,42,63));
var
Color,Component,Value:byte;
NewRed,NewGreen,NewBlue:byte;
begin
DecreaseColor256:=0;
Component:=1;
repeat
case Component of
1:Value:=SimplifyColorComponent(Red div 4);
2:Value:=SimplifyColorComponent(Green div 4);
3:Value:=SimplifyColorComponent(Blue div 4);
end;
Color:=0;
while Value<>Palette16[Color,Component] do
begin
Inc(Color);
if Color>15 then
begin
Dec(Value,21);
Color:=0;
end;
end;
case Component of
1:NewRed:=Value;
2:NewGreen:=Value;
3:NewBlue:=Value;
end;
Inc(Component);
until Component>3;
for Color:=0 to 15 do
if (Palette16[Color,1]=NewRed) and (Palette16[Color,2]=NewGreen)
and (Palette16[Color,3]=NewBlue) then
begin
DecreaseColor256:=Color;
Exit;
end;
end;
end.

复制代码

FlierMate. · 发表于 4-3-2011 06:53 PM

至于另外的Video、Mouse模块很普通（大家的都是一样的），在这里就不列出来了。

FlierMate_ · 发表于 4-3-2011 10:24 PM

再来就是自行研发类似RLE(Run-Length Encoding)低效率的压缩技术----SqueezeTogether。

unit Compress;
{
Squeeze-Together(im) Compression Technology
Revision 1 (1999)
Researched and Developed by Boo Khan Ming
Compress all types of file regardless of file size.
}
interface
function SqueezeFile(InputFileName,OutputFileName:string):byte;
function StretchFile(InputFileName,OutputFileName:string):byte;
implementation
uses DOS;
type
DataType=array [0..63999] of byte;
var
Data:^DataType;
DataSize:longint;
SegmentIndex:longint;
InputFile:file;
OutputFile:file;
FrequencyTable:array [1..256] of word;
FrequencyTableSize:word;
UsedCodeList,UnusedCodeList:array [1..256] of byte;
UsedCode,UnusedCode:word;
FrequentlyUsedCodeList:array [1..256] of byte;
CodeMap:array [1..256] of longint;
Counter:longint;
Loop:word;
Code:byte;
Frequency:byte;
CollectMode:boolean;
Found:boolean;
AccessStatus:word;
FileDateTime:longint;
P1,P2:PathStr;
D1,D2:DirStr;
N1,N2:NameStr;
E1,E2:ExtStr;
function SqueezeFile(InputFileName,OutputFileName:string):byte;
{
Status Code
0 = Successful
1 = Insufficient Memory
2 = Unable to open input file
3 = File access error
4 = Unable to compress file
5 = Unable to create output file
255 = Undefined error
}
function FetchCode(Index:longint):byte;
var
Refresh:boolean;
begin
FetchCode:=0;
if Index-1>DataSize then
Exit;
Refresh:=False;
if ((Index-1) div 64000)<>SegmentIndex then
begin
SegmentIndex:=(Index-1) div 64000;
Refresh:=True;
end;
if Refresh then
begin
{$I-}
Seek(InputFile,SegmentIndex*64000);
BlockRead(InputFile,Data^,64000,AccessStatus);
{$I+}
if IOResult<>0 then
begin
SqueezeFile:=3;
Exit;
end;
end;
FetchCode:=Data^[(Index-1) mod 64000];
end;
procedure AnalyseUsedCode;
var
Counter:longint;
Loop:word;
Found:boolean;
begin
UsedCode:=0;
FillChar(UsedCodeList,SizeOf(UsedCodeList),0);
for Counter:=1 to DataSize do
begin
Code:=FetchCode(Counter);
Inc(CodeMap[Code+1]);
Found:=False;
for Loop:=1 to UsedCode do
if UsedCodeList[Loop]=Code then
begin
Found:=True;
Break;
end;
if not Found then
begin
Inc(UsedCode);
UsedCodeList[UsedCode]:=Code;
end;
end;
end;
procedure AnalyseUnusedCode;
var
Counter:word;
Loop:word;
Found:boolean;
begin
UnusedCode:=0;
FillChar(UnusedCodeList,SizeOf(UnusedCodeList),0);
for Counter:=0 to 255 do
begin
Found:=False;
for Loop:=1 to UsedCode do
if UsedCodeList[Loop]=Counter then
begin
Found:=True;
Break;
end;
if not Found then
begin
Inc(UnusedCode);
UnusedCodeList[UnusedCode]:=Counter;
end;
end;
end;
procedure AnalyseFrequentlyUsedCode;
var
Loop1,Loop2:word;
Frequency:longint;
Index:byte;
Code:word;
begin
for Code:=1 to 256 do
FrequentlyUsedCodeList[Code]:=Code-1;
for Loop1:=2 to 256 do
begin
Frequency:=CodeMap[Loop1];
Index:=FrequentlyUsedCodeList[Loop1];
Loop2:=Loop1-1;
while (Frequency>CodeMap[Loop2]) and (Loop2>0) do
begin
CodeMap[Loop2+1]:=CodeMap[Loop2];
FrequentlyUsedCodeList[Loop2+1]:=FrequentlyUsedCodeList[Loop2];
Loop2:=Loop2-1;
end;
CodeMap[Loop2+1]:=Frequency;
FrequentlyUsedCodeList[Loop2+1]:=Index;
end;
end;
function FindReferenceIndex(Code:byte):byte;
var
Loop:word;
begin
FindReferenceIndex:=0;
for Loop:=1 to FrequencyTableSize do
if FrequentlyUsedCodeList[Loop]=Code then
begin
FindReferenceIndex:=UnusedCodeList[Loop];
Break;
end;
end;
function FindCodeIndex(Code:byte):byte;
var
Loop:word;
begin
FindCodeIndex:=0;
for Loop:=1 to FrequencyTableSize do
if UnusedCodeList[Loop]=Code then
begin
FindCodeIndex:=FrequentlyUsedCodeList[Loop];
Break;
end;
end;
procedure StoreCode;
begin
Code:=FetchCode(Counter);
BlockWrite(OutputFile,Code,1);
end;
procedure CompactCode;
begin
Code:=FindReferenceIndex(FetchCode(Counter-1));
BlockWrite(OutputFile,Code,1);
BlockWrite(OutputFile,Frequency,1);
Frequency:=0;
end;
begin
SqueezeFile:=255;
if MaxAvail<64000 then
begin
SqueezeFile:=1;
Exit;
end;
{$I-}
Assign(InputFile,InputFileName);
Reset(InputFile,1);
{$I+}
if (IOResult<>0) or (FileSize(InputFile)=0) then
begin
SqueezeFile:=2;
Exit;
end;
DataSize:=FileSize(InputFile);
SegmentIndex:=0;
New(Data);
{$I-}
Seek(InputFile,SegmentIndex*64000);
BlockRead(InputFile,Data^,64000,AccessStatus);
{$I+}
if IOResult<>0 then
begin
SqueezeFile:=3;
Exit;
end;
AnalyseUsedCode;
AnalyseUnusedCode;
AnalyseFrequentlyUsedCode;
if UnusedCode=0 then
begin
SqueezeFile:=4;
Exit;
end;
P1:=InputFileName;
P2:=OutputFileName;
FSplit(P1,D1,N1,E1);
FSplit(P2,D2,N2,E2);
if (D2='') and (D1<>'') then
begin
D2:=D1;
P2:=D2+N2+E2;
end;
{$I-}
Assign(OutputFile,P2);
Rewrite(OutputFile,1);
{$I+}
if IOResult<>0 then
begin
SqueezeFile:=5;
Exit;
end;
if UnusedCode>UsedCode then
FrequencyTableSize:=UsedCode
else
FrequencyTableSize:=UnusedCode;
for Counter:=1 to FrequencyTableSize do
FrequencyTable[Counter]:=(UnusedCodeList[Counter] shl 8)+FrequentlyUsedCodeList[Counter];
BlockWrite(OutputFile,FrequencyTableSize,2);
BlockWrite(OutputFile,FrequencyTable,FrequencyTableSize*2);
Counter:=1;
Frequency:=0;
CollectMode:=False;
repeat
Found:=False;
for Loop:=1 to FrequencyTableSize do
if FetchCode(Counter)=FrequentlyUsedCodeList[Loop] then
begin
Found:=True;
Break;
end;
if CollectMode then
if FetchCode(Counter)<>FetchCode(Counter-1) then
begin
CompactCode;
CollectMode:=False;
end;
if (Found) or (CollectMode) then
begin
if Counter+2<DataSize then
begin
if (FetchCode(Counter)=FetchCode(Counter+1)) and (Frequency<252) then
begin
if (FetchCode(Counter+1)=FetchCode(Counter+2)) and (Frequency<252) then
begin
Inc(Frequency,3);
Inc(Counter,3);
CollectMode:=True;
end
else
begin
Inc(Frequency,2);
Inc(Counter,2);
CollectMode:=False;
CompactCode;
end;
end
else
CollectMode:=False;
end
else
CollectMode:=False;
if not CollectMode then
if Frequency>0 then
begin
Inc(Frequency);
Inc(Counter);
CompactCode;
end
else
begin
StoreCode;
Inc(Counter);
end;
end
else
begin
StoreCode;
Inc(Counter);
end;
until (Counter>DataSize) and (Frequency=0);
GetFTime(InputFile,FileDateTime);
SetFTime(OutputFile,FileDateTime);
Close(InputFile);
Close(OutputFile);
Dispose(Data);
SqueezeFile:=0;
end;

复制代码

FlierMate_ · 发表于 4-3-2011 10:25 PM

function StretchFile(InputFileName,OutputFileName:string):byte;
{
Status Code
0 = Successful
1 = Insufficient Memory
2 = Unable to open input file
3 = File access error
5 = Unable to create output file
255 = Undefined error
}
function FetchCode(Index:longint):byte;
var
Refresh:boolean;
SeekIndex:longint;
begin
FetchCode:=0;
if Index-1>DataSize-((FrequencyTableSize*2)+2) then
Exit;
Refresh:=False;
if ((Index-1) div 64000)<>SegmentIndex then
begin
SegmentIndex:=(Index-1) div 64000;
Refresh:=True;
end;
if Refresh then
begin
SeekIndex:=((FrequencyTableSize*2)+2)+(SegmentIndex*64000);
{$I-}
Seek(InputFile,SeekIndex);
BlockRead(InputFile,Data^,64000,AccessStatus);
{$I+}
if IOResult<>0 then
begin
StretchFile:=3;
Exit;
end;
end;
FetchCode:=Data^[(Index-1) mod 64000];
end;
begin
StretchFile:=255;
if MaxAvail<64000 then
begin
StretchFile:=1;
Exit;
end;
{$I-}
Assign(InputFile,InputFileName);
Reset(InputFile,1);
{$I+}
if (IOResult<>0) or (FileSize(InputFile)=0) then
begin
StretchFile:=2;
Exit;
end;
DataSize:=FileSize(InputFile);
SegmentIndex:=0;
New(Data);
{$I-}
BlockRead(InputFile,FrequencyTableSize,2);
BlockRead(InputFile,FrequencyTable,FrequencyTableSize*2);
{$I+}
if IOResult<>0 then
begin
StretchFile:=3;
Exit;
end;
{$I-}
BlockRead(InputFile,Data^,64000,AccessStatus);
{$I+}
if IOResult<>0 then
begin
StretchFile:=3;
Exit;
end;
P1:=InputFileName;
P2:=OutputFileName;
FSplit(P1,D1,N1,E1);
FSplit(P2,D2,N2,E2);
if (D2='') and (D1<>'') then
begin
D2:=D1;
P2:=D2+N2+E2;
end;
{$I-}
Assign(OutputFile,P2);
Rewrite(OutputFile,1);
{$I+}
if IOResult<>0 then
begin
StretchFile:=5;
Exit;
end;
Counter:=1;
repeat
Found:=False;
for Loop:=1 to FrequencyTableSize do
if FetchCode(Counter)=Byte(FrequencyTable[Loop] shr 8) then
begin
Code:=Byte(FrequencyTable[Loop]);
Frequency:=FetchCode(Counter+1);
Inc(Counter,2);
Found:=True;
Break;
end;
if Found then
begin
for Loop:=1 to Frequency do
BlockWrite(OutputFile,Code,1);
end
else
begin
Code:=FetchCode(Counter);
BlockWrite(OutputFile,Code,1);
Inc(Counter);
end;
until Counter>DataSize-((FrequencyTableSize*2)+2);
GetFTime(InputFile,FileDateTime);
SetFTime(OutputFile,FileDateTime);
Close(InputFile);
Close(OutputFile);
Dispose(Data);
StretchFile:=0;
end;
end.

复制代码

--完--

FlierMate_ · 发表于 4-3-2011 10:33 PM

想在屏幕上显示比Turbo Pascal独有的WriteLn更快的字串？

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

unit DirectText;
{
DirectText Technology
Revision 1 (1997)
Developed by Boo Khan Ming
Enhance the text mode performance with direct video memory access.
}
interface
procedure ChangeTextOffset(X,Y:byte);
procedure ChangeTextRegion(X1,Y1,X2,Y2:byte);
function RequestTextOffsetX:byte;
function RequestTextOffsetY:byte;
procedure ClearTextContent;
procedure ChangeTextAppearance(OldColor,NewColor:byte);
procedure InsertText(Content:string);
procedure InsertNewText(Content:string);
procedure InsertSingleText(Content:char);
procedure InsertMultipleText(Content,Count:byte);
procedure InsertNewMultipleText(Content,Count:byte);
implementation
uses CRT;
const
TextContentLimitX=80;
TextContentLimitY=25;
type
TextContentType=array [0..(TextContentLimitX*TextContentLimitX)-1] of word;
var
TextContent:TextContentType absolute $b800:0;
TextContentOffsetX,TextContentOffsetY:byte;
TextContentLowerBoundX,TextContentLowerBoundY:byte;
TextContentUpperBoundX,TextContentUpperBoundY:byte;
CursorPosition:word absolute $0000:$0450;
Counter:byte;
procedure AutoAdjustTextOffset;
begin
if TextContentOffsetX<TextContentLowerBoundX then
TextContentOffsetX:=TextContentLowerBoundX;
if TextContentOffsetY<TextContentLowerBoundY then
TextContentOffsetY:=TextContentLowerBoundY;
if TextContentOffsetX>TextContentUpperBoundX then
begin
TextContentOffsetX:=TextContentLowerBoundX;
Inc(TextContentOffsetY);
end;
if TextContentOffsetY>TextContentUpperBoundY then
TextContentOffsetY:=TextContentUpperBoundY;
{
asm
mov ah, 02h
xor bh, bh
mov dh, TextContentOffsetY-1
mov dl, TextContentOffsetX-1
int 10h
end;
}
{ CursorPosition:=(TextContentOffsetX shl 8)+TextContentOffsetY;}
{ GotoXY(TextContentOffsetX,TextContentOffsetY);}
end;
procedure ChangeTextOffset(X,Y:byte);
begin
TextContentOffsetX:=TextContentLowerBoundX+X-1;
TextContentOffsetY:=TextContentLowerBoundY+Y-1;
GotoXY(TextContentOffsetX,TextContentOffsetY);
end;
procedure ChangeTextRegion(X1,Y1,X2,Y2:byte);
begin
TextContentLowerBoundX:=X1;
TextContentLowerBoundY:=Y1;
TextContentUpperBoundX:=X2;
TextContentUpperBoundY:=Y2;
TextContentOffsetX:=TextContentLowerBoundX;
TextContentOffsetY:=TextContentLowerBoundY;
end;
function RequestTextOffsetX:byte;
begin
RequestTextOffsetX:=TextContentOffsetX;
end;
function RequestTextOffsetY:byte;
begin
RequestTextOffsetY:=TextContentOffsetY;
end;
procedure ClearTextContent;
var
CounterX,CounterY:byte;
begin
for CounterX:=TextContentLowerBoundX to TextContentUpperBoundX do
for CounterY:=TextContentLowerBoundY to TextContentUpperBoundY do
TextContent[(CounterY-1)*TextContentLimitX+CounterX-1]:=255+TextAttr shl 8;
end;
procedure ChangeTextAppearance(OldColor,NewColor:byte);
var
Counter:word;
begin
Counter:=1;
repeat
if (Mem[$b800:Counter] and $f0)=(OldColor shl 4) then
Mem[$b800:Counter]:=(Mem[$b800:Counter] and $0f) or (NewColor shl 4);
Inc(Counter,2);
until Counter>4000;
end;
procedure InsertText(Content:string);
begin
for Counter:=1 to Length(Content) do
begin
TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content[Counter])+TextAttr shl 8;
Inc(TextContentOffsetX);
AutoAdjustTextOffset;
end;
end;
procedure InsertNewText(Content:string);
begin
for Counter:=1 to Length(Content) do
begin
TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content[Counter])+TextAttr shl 8;
Inc(TextContentOffsetX);
AutoAdjustTextOffset;
end;
TextContentOffsetX:=TextContentLowerBoundX;
Inc(TextContentOffsetY);
AutoAdjustTextOffset;
end;
procedure InsertSingleText(Content:char);
begin
TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content)+TextAttr shl 8;
Inc(TextContentOffsetX);
AutoAdjustTextOffset;
end;
procedure InsertMultipleText(Content,Count:byte);
begin
for Counter:=1 to Count do
begin
TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content)+TextAttr shl 8;
Inc(TextContentOffsetX);
AutoAdjustTextOffset;
end;
end;
procedure InsertNewMultipleText(Content,Count:byte);
begin
for Counter:=0 to Count do
begin
TextContent[(TextContentOffsetY-1)*TextContentLimitX+TextContentOffsetX-1]:=Ord(Content)+TextAttr shl 8;
Inc(TextContentOffsetX);
AutoAdjustTextOffset;
end;
TextContentOffsetX:=TextContentLowerBoundX;
Inc(TextContentOffsetY);
AutoAdjustTextOffset;
end;
begin
TextContentLowerBoundX:=1;
TextContentLowerBoundY:=1;
TextContentUpperBoundX:=TextContentLimitX;
TextContentUpperBoundY:=TextContentLimitY;
TextContentOffsetX:=TextContentLowerBoundX;
TextContentOffsetY:=TextContentLowerBoundY;
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

哗！太好了。谢谢！

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的了....

		自动登录	找回密码
密码			注册

谁要.PAS源代码？

……接上

……续上

所属分类: 电脑手机

浏览过的版块