第二章 实用工具单元
来源：互联网 发布：同盾大数据查询 编辑：程序博客网 时间：2024/05/16 17:21
作者在长期使用TURBO PASCAL编程的过程中积累了许多实用的PASCAL过程和函数，并归并为几类TURBO PASCAL程序单元，这些单元大多是用TURBO PASCAL和TURBO汇编混合编程的，既具有很高的实用价值，又具有学习TURBO PASCAL编程技术的作用，现把它们奉献给广大读者。这些程序单元包括：屏幕输入输出单元ACRT，字符串处理单元ASRT，磁盘输入输出单元DISK，热键(Hotkey)单元POPUP，数据库交互单元DBASE、扩展内存使用单元EMS、扩充内存使用单元XMS、数学函数单元MATH，矩阵运算单元MATRIX、概率分布单元PROB和复数运算单元COMPLEX。这些单元适合于TURBO PASCAL 4.0及以上的各种TURBO PASCAL版本，对TURBO PASCAL 6.0及以上版本可以将汇编程序改写为内嵌式汇编，这里为方便TURBO PASCAL 6.0以下的读者，提供了独立的TURBO汇编源程序。读者可以将这些单元直接编译后使用，也可以根据需要扩充修改，同时可以从中学习TURBO PASCAL与汇编语言混合编程的方法、编写DOS中断例程的方法、过程或函数作为参数传递的方法等TURBO PASCAL的高级用法。
§2.1 屏幕输入输出单元ACRT
屏幕输入输出单元是与显示器有关的一些过程和函数的集合，包括有设置光标大小、设置和获取显示页、设置和获取显示模态、打开和关闭电子钟等12个过程和函数，它是对TURBO PASCAL的CRT单元的扩展和补充。
ACRT单元的一部分是用TURBO ASSEMBLER编写的，其代码在ACRT.ASM中，其余代码在ACRT.PAS中，汇编程序可以使用TASM的各种版本汇编为目标文件(.OBJ)，供TURBO PASCAL编译器使用。下面介绍ACRT单元的12个过程和函数的用法。
§2.1.1 ACRT的函数和过程
1.CrtType函数
功 能 返回计算机显示器的类型
用 法 CrtType
结果类型 字符型
返 回 值 'M'代表单色显示器，'C'代表彩色显示器
2.SetCursor过程
功 能 设置光标的大小
用 法 SetCursor(t:byte)
说 明 t是字节型值参，可取0，1，2三个值，t=0时光标消失，t=1时为小光标，t=2为大光标。
3.SetCrtMode过程
功 能 把显示器设置为不同的显示模态，如文本或图形
用 法 SetCrtMode(i:byte)
说 明 i可以取显示器可识别的各种模态，MDA为7，CGA为0-6，EGA为0-16， VGA为0-19，如附录2。用此过程可以在使用CRT的同时,在屏幕上显示汉字!
4.GetCrtMode函数
功 能 获取显示器模态值
用 法 GetCrtMode
结果类型 字节型
说 明 返回显示器的当前显示模态，见附录2。
返 回 值 返回显示模态值
5.SetVPage过程
功 能 设置一显示页为当前显示页
用 法 SetVPage(i:byte)
说 明 i可取显示卡可接受的值，对CGA为0-1，对EGA和VGA为0-3
6.GetVPage函数
功 能 获取当前显示页号
用 法 GetVPage
结果类型 字节型
返 回 值 返回显示页号值
7.OpenClock过程
功 能 在屏幕右上角显示一个电子钟
用 法 OpenClock(TA:byte)
说 明 TA代表文本显示属性，可取0-255之间的值
8.CloseClock过程
功 能 关闭屏幕右上角的电子钟
用 法 CloseClock
9.WriteXY过程
功 能 在屏幕上指定位置按给定的属性写字符串
用 法 WriteXY(x,y,TA : word; s: string)
说 明 x为行值，y为列值，TA为文本属性，s为待显示的字符串
10.YesNo函数
功 能 向用户提出一个是否(Yes、No)的问题
用 法 YesNo(s:string)
结果类型 布尔型
说 明 s代表提问内容字符串
返 回 值 True或False
11.LargeChar过程
功 能 显示一个放大了的字符
用 法 LargeChar(x,y,ch,bc,fc : integer)
说 明 x为屏幕行值，y屏幕列值，ch为待显示的字符的ASCII码值，bc为屏幕背景色，fc为屏幕前景色
12.ReBoot过程
功 能 重新启动计算机
用 法 Reboot
§2.1.2 ACRT的使用
ACRTDEMO.PAS演示了ACRT中部分过程和函数的用法。过程ClockDemo演示了两个电子钟过程的使用，VPageDemo演示了设置显示页过程的用法，DisplayLargeChar演示了在屏幕上显示大型ASCII字符过程LargeChar的用法。
§2.1.3 源程序清单
程序1:ACRT.PAS
{************************************}
{ UNIT : ACRT }
{ Advanced CRT Interface Unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{************************************}
unit ACRT;
{$D-,S-}
interface
uses Crt;
function CrtType:Char;
procedure OpenClock(TA:byte);{ Display a clock on screen }
procedure CloseClock; { Remove the clock }
procedure SetCursor(t:byte);{ Set current cursor routine }
procedure SetVPage(i:byte);
function GetVPage:byte;
procedure SetCrtMode(i:byte);
function GetCrtMode:byte;
procedure LargeChar(x,y,Ch,bc,fc:integer);
procedure WriteXY(x,y,TA:word;S:string);
function YesNo(s:string):boolean;
procedure reboot;
inline($EA/$00/$00/$FF/$FF); { jmp FFFF:0000 }
implementation
{$L ACRT}
function CrtType;
external {ACRT};
procedure OpenClock(TA:byte);
external {ACRT};
procedure CloseClock;
external {ACRT};
procedure SetCursor;
external {ACRT};
procedure SetVPage;
external {ACRT};
function GetVPage;
external {ACRT};
procedure SetCrtMode;
external {ACRT};
function GetCrtMode;
external {ACRT};
procedure LargeChar;
const UsedChar = 219;
type ROMChar = array[1..8] of byte;
var CharTable : array[0..255] of ROMChar absolute $f000:$Fa6e;
i,j,OldAttr : integer;
Pattern : ROMChar;
begin
OldAttr := TextAttr;
TextAttr := bc * 16 + fc;
Pattern := CharTable[Ch];
for i := 1 to 8 do
for j := 7 downto 0 do
begin
GotoXY(x-1+8-j,y-1+i);
if (odd(Pattern[i] shr j )) then write(chr(UsedChar));
end;
TextAttr := OldAttr;
end;
procedure WriteXY;
begin
GotoXY(x,y);
TextAttr := TA;
Write(S);
end;
function YesNo(s:string):boolean;
var ch : char;
str: string[1];
begin
str := '';
YesNo := false;
write(s,' (Y/N)?');
readln(str);
ch := str[1];
if ch in ['y','Y'] then YesNo := true;
end;
end.
程序2:ACRT.ASM
; ACRT.ASM
; Assembler include file for ACRT.PAS unit
TITLE ACRT
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; procedure SetVPage;
PUBLIC SetVPage
SetVPage:
PUSH BP
MOV BP,SP
MOV AX,[BP+6]
MOV AH,5
INT 10H
POP BP
RETF 2
; function GetVPage;
PUBLIC GetVPage
GetVPage:
MOV AX,40H
PUSH AX
POP ES
MOV AL,BYTE PTR ES:[62H]
MOV AH,00
RETF
; procedure SetCrtMode;
PUBLIC SetCrtMode
SetCrtMode:
PUSH BP
MOV BP,SP
MOV AL,[BP+6]
MOV AH,0
INT 10H
POP BP
RETF 2
; function GetCrtMode;
PUBLIC GetCrtMode
GetCrtMode:
MOV AX,40H
PUSH AX
POP ES
MOV AL,BYTE PTR ES:[49H]
MOV AH,00
RETF
; function CrtType:byte;
PUBLIC CrtType
CrtType:
MOV AX,40H
PUSH AX
POP ES
CMP BYTE PTR ES:[49H],7
JZ @@1
MOV AL,'C' ; Color
JMP @@2
@@1: MOV AL,'M' ; Monochrome
@@2: MOV AH,00
RETF
; procedure SetCursor(T:byte);
; T=0 No Cursor
; T=1 Small Cursor
; T=2 Big Cursor
PUBLIC SetCursor
SetCursor:
PUSH BP
MOV BP,SP
MOV AX,40H
PUSH AX
POP ES
MOV BX,[BP+6]
CMP BYTE PTR ES:[49H],7
JE @@1
CMP BL,02
JE @@2
CMP BL,01
JE @@3
JMP @@6
@@1: CMP BL,02
JE @@4
CMP BL,01
JE @@3
@@6: MOV CX,2000H
JMP @@7
@@3: MOV CX,0001H
JMP @@7
@@2: MOV CX,0007H
JMP @@7
@@4: MOV CX,000CH
@@7: MOV ES:[60H],CX
POP BP
RETF 2
; Int 1CH
Int1C:
PUSH ES
PUSH DS
PUSH DX
PUSH CX
PUSH AX
JMP @@3
OS DB 00H
TA DB 79H
@@3: MOV AH,02
INT 1AH
MOV AL,DH
CALL Bcd2DecAscii
CMP CS:OS,AL
JE @@2
PUSH AX
MOV AX,40H
PUSH AX
POP ES
MOV AX,0B000H
CMP BYTE PTR ES:[49H],7
JE @@1
MOV AX,0B800H
@@1: MOV DS,AX
POP AX
MOV DL,CS:TA
MOV CS:OS,AL
MOV BYTE PTR DS:[159],DL
MOV BYTE PTR DS:[158],AL
MOV BYTE PTR DS:[157],DL
MOV BYTE PTR DS:[156],AH
MOV AL,CL
CALL Bcd2DecAscii
MOV BYTE PTR DS:[155],DL
MOV BYTE PTR DS:[154],':'
MOV BYTE PTR DS:[153],DL
MOV BYTE PTR DS:[152],AL
MOV BYTE PTR DS:[151],DL
MOV BYTE PTR DS:[150],AH
MOV AL,CH
CALL Bcd2DecAscii
MOV BYTE PTR DS:[149],DL
MOV BYTE PTR DS:[148],':'
MOV BYTE PTR DS:[147],DL
MOV BYTE PTR DS:[146],AL
MOV BYTE PTR DS:[145],DL
MOV BYTE PTR DS:[144],AH
@@2:
POP AX
POP CX
POP DX
POP DS
POP ES
IRET
; Translate BCD Code to Decimal ASCII Code
; IN AL BCD Code
; OUT AX Decimal ASCII CODE
Bcd2DecAscii:
PUSH CX
MOV CH,AL
AND CH,0FH
MOV AH,CH
ADD AH,30H
MOV CL,4
SHR AL,CL
ADD AL,30H
XCHG AH,AL
POP CX
RET
; procedure OpenClock(TA:byte);
; procedure CloseClock;
PUBLIC OpenClock
PUBLIC CloseClock
Int1cSeg DW 0000h
InT1cOffset DW 0000h
OpenClock:
PUSH BP
MOV BP,SP
MOV CX,[BP+6]
MOV CS:TA,CL
SUB AX,AX
MOV ES,AX
MOV AX,ES:[70H]
MOV CS:Int1cOffset,AX
MOV AX,ES:[72H]
MOV CS:Int1cSeg,AX
MOV AX,OFFSET Int1C
MOV BX,SEG Int1C
CLI
MOV ES:[70H],AX
MOV ES:[72H],BX
STI
POP BP
RETF 2
CloseClock:
SUB AX,AX
MOV ES,AX
MOV AX,CS:Int1cOffset
CMP AX,0000H
JE @@1
CLI
MOV ES:[70H],AX
MOV AX,CS:Int1cSeg
MOV ES:[72H],AX
STI
@@1: RETF
END
程序3:ACRTDEMO.PAS
{-----------------------------------}
{ ACRTDEMO.PAS }
{ Demonstrates the usage of ACRT }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
program ACrtDemo;
uses Crt,ACrt;
procedure ClockDemo(disp:boolean);
begin
if disp then OpenClock(12)
else CloseClock;
end;
procedure VPageDemo;
var i : integer;
begin
for i := 1 to 3 do
begin
setvpage(i);
delay(2000);
end;
setvpage(0);
end;
procedure DisplayLargeChar;
var i,j : integer;
begin
for i := 1 to 4 do
begin
clrscr;
writeln(i);
LargeChar(10,10,65,1,10+i*2);
LargeChar(20,10,66,1,14+i*2);
LargeChar(30,10,67,1,15+i*2);
for j := 1 to $1000 do
move(mem[$B800:j],mem[$B800 + i*$100:j],1);
end;
end;
begin
clrscr;
ClockDemo(true);
DisplayLargeChar;
VPageDemo;
ClockDemo(false);
clrscr;
end.
§2.2 字符串处理单元ASTR
字符串处理单元ASTR是专门处理与字符串有关的过程和函数的集合，包括十六进制数字串、以特定字符填充字符串、数字转字符串、日期和时间字符串、生成空格串、字符串的大小写转换等。它是TURBO PASCAL字符串功能的有益补充。
ASTR单元是用TURBO PASCAL和TURBO汇编混合编程的，代码分别存放在ASTR.PAS和ASTR.ASM中，ASTR.ASM可用TASM汇编为目标文件(.OBJ)，供TURBO PASCAL编译器使用。下面介绍10个函数的功能和调用方法。
§2.2.1 ASTR的函数和过程
1.HexStr函数
功 能 把给定变量的内容转换成十六进制字符串
用 法 HexStr(var Num; ByteCount: Byte)
结果类型 字符串类型
说 明 Num为待转换成十六进制串的变量，可以是字节整数、字型整数、有符号整数、长整数、字符、字符串等。ByteCount为待转换变量的字节数。
返 回 值 十六进制字符串
2.FillCharToStr函数
功 能 按指定字符填充指定长度的字符串
用 法 FillCharToStr(Len: Byte; Ch: Char)
结果类型 字符串类型
说 明 Len为字符串的长度;Ch为指定的字符
返 回 值 一定长度的指定字符的字符串
3.WordToStr函数
功 能 把给定的字型整数转换为指定长度的字符串
用 法 WordToStr(Num : Word; Len: Byte)
结果类型 字符串类型
说 明 Num为字型整数；Len为待生成的字符串的长度
返 回 值 指定长度的字型整数串
4.IntToStr函数
功 能 把给定的整型数转换为指定长度的字符串
用 法 IntToStr(Num: Integer; Len: Byte)
结果类型 字符串类型
说 明 Num为整型数；Len为待生成的字符串的长度
返 回 值 指定长度的整型数串
5.实型数字符串函数RealToStr
功 能 把给定的实型数转换为指定格式的字符串
用 法 RealToStr(Num: Real; Len, Places: Byte)
结果类型 字符串类型
说 明 Num为实型数；Len为待生成的字符串的长度；Places为小数位数
返 回 值 指定格式的实型数字符串
6.DateStr函数
功 能 生成当前日期的字符串
用 法 DateStr
结果类型 字符串类型
返 回 值 当前日期的字符串，格式为"Sunday July 17, 1994"
7.TimeStr函数
功 能 生成当前时间的字符串
用 法 TimeStr
结果类型 字符串类型
返 回 值 当前时间的字符串，格式为"2:20 PM"
8.Space函数
功 能 生成指定长度的空格字符串
用 法 Space(Len : Byte)
结果类型 字符串类型
说 明 Len为待生成字符串的长度
返 回 值 指定长度的空格字符串
9.UpperStr函数
功 能 把给定的字符串转换为大写字符串
用 法 UpperStr(var S : string)
结果类型 字符串类型
说 明 S为源字符串,变量
返 回 值 大写的字符串
10.LowerStr函数
功 能 把给定的字符串转换为小写字符串
用 法 LowerStr(var S : string)
结果类型 字符串类型
说 明 S为源字符串,变量
返 回 值 小写的字符串
§2.2.2 ASTR的使用
ASTRDEMO.PAS演示了ASTR中部分过程和函数的用法。UpLowDemo演示了UpperStr和LowerStr函数的用法，它把26个大写字母转换为相应的小写字母，HexStrDemo演示了HexStr函数的用法，它自动生成ASCII码全集的十进制和十六进制字符串，并显示到屏幕上，DateTimeDemo演示了DateStr和TimeSTr函数，把当前的日期和时间以直观的形式显示到屏幕上。
§2.2.3 源程序清单
程序1：ASTR.PAS
{*****************************************}
{ UNIT : ASTR }
{ Advanced String Interface Unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{*****************************************}
Unit ASTR;
{$D-,S-}
interface
uses dos;
Function HexStr(var Num; ByteCount: Byte) : String;
Function FillCharToStr(Len: Byte; Ch: Char) : String;
Function WordToStr(Num: Word; Len: Byte): String;
Function IntToStr(Num: Integer; Len: Byte): String;
Function RealToStr(Num: Real; Len, Places: Byte) : String;
Function DateStr : String;
Function TimeStr : String;
Function Space(Len : Byte) : String;
Function UpperStr(S : string) : String;
Function LowerStr(S : string) : String;
implementation
{$L ASTR.OBJ}
function HexStr;
external; { ASTR }
Function UpperStr(S : string) : String;
external;
Function LowerStr(S : string) : String;
external;
function FillCharToStr;
var
S: String;
begin
S[0] := Chr(Len);
FillChar(S[1],Len,Ch);
FillCharToStr := S;
end;
Function Space;
begin
Space := FillCharToStr(Len,' ');
end;
function WordToStr;
var
S : String[5];
begin
Str(Num:Len, S);
WordToStr := S;
end; { WordToStr }
function IntToStr;
var
S : String[5];
begin
Str(Num:Len, S);
IntToStr := S;
end; { IntToStr }
function RealToStr;
var
S : String[80];
begin
Str(Num:Len:Places, S);
RealToStr := S;
end; { RealToString }
Function DateStr;
type
WeekDays = array[0..6] of string[9];
Months = array[1..12] of string[9];
const
DayNames : WeekDays = ('Sunday','Monday','Tuesday','Wednesday',
'Thursday','Friday','Saturday');
MonthNames : Months = ('January','February','March','April','May',
'June','July','August','September',
'October','November','December');
BlankStr : string[1] = ' ';
CommaStr : string[1] = ',';
var
DayOfWeek : Word;
Year,Month,Day: Word;
YearStr : string[4];
DayStr : string[2];
begin
GetDate(Year,Month,Day,DayOfWeek);
Str(Year:4,YearStr);
Str(Day,DayStr);
DateStr := DayNames[DayOfWeek] + BlankStr + MonthNames[Month] +
BlankStr + DayStr + CommaStr + BlankStr + YearStr
end;
Function TimeStr;
type
AmPm = array[0..1] of string[3];
const
AmPmStr : AmPm = (' AM',' PM');
Colon : string[1] = ':';
var
TmpHours,TmpMins : Word;
HourStr,MinStr : string[2];
AmIndex : Word;
Hours,Minutes,Seconds,Tics: Word;
begin
GetTime(Hours,Minutes,Seconds,Tics);
TmpHours := Hours;
TmpMins := Minutes;
if (Seconds > 30) then
begin
TmpMins := Succ(TmpMins) mod 60;
if (TmpMins = 0) then
TmpHours := Succ(TmpHours) mod 24
end;
if (TmpHours < 12) then
begin
AmIndex := 0;
if (TmpHours = 0) then
TmpHours := 12
end
else
begin
AmIndex := 1;
if (TmpHours > 12) then
TmpHours := TmpHours - 12
end;
Str(TmpMins:2,MinStr);
if (TmpMins < 10) then MinStr[1] := '0';
Str(TmpHours,HourStr);
TimeStr := HourStr + Colon + MinStr + AmPmStr[AmIndex]
end;
end.
程序2：ASTR.ASM
; ASTR.ASM (Turbo Assembler Program)
; Assembler include file for ASTR.PAS unit
; Writen by Dong Zhanshanin 1994
Title ASTR
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; Parameters (+2 because of push bp)
byteCount equ byte ptr ss:[bp+6]
num equ dword ptr ss:[bp+8]
; Function result address (+2 because of push bp)
resultPtr equ dword ptr ss:[bp+12]
PUBLIC HexStr
HexStr:
push bp
mov bp,sp ;get pointer into stack
les di,resultPtr ;get address of function result
mov dx,ds ;save Turbo's DS in DX
lds si,num ;get number address
mov al,byteCount ;how many bytes?
xor ah,ah ;make a word
mov cx,ax ;keep track of bytes in CX
add si,ax ;start from MS byte of number
dec si
shl ax,1 ;how many digits? (2/byte)
cld ;store # digits (going forward)
stosb ;in destination string's length byte
HexLoop:
std ;scan number from MSB to LSB
lodsb ;get next byte
mov ah,al ;save it
shr al,1 ;extract high nibble
shr al,1
shr al,1
shr al,1
add al,90h ;special hex conversion sequence
daa ;using ADDs and DAA's
adc al,40h
daa ;nibble now converted to ASCII
cld ;store ASCII going up
stosb
mov al,ah ;repeat conversion for low nibble
and al,0Fh
add al,90h
daa
adc al,40h
daa
stosb
loop HexLoop ;keep going until done
mov ds,dx ;restore Turbo's DS
pop bp
retf 6 ;parameters take 6 bytes
; function UpperStr
Public UpperStr
ResStr EQU Dword ptr [bp+10]
S EQU Dword ptr [bp+6]
UpperStr:
push bp ; Save BP
mov bp,sp ; Save up stack frame
push ds ; Save DS
xor ch,ch
mov bx,offset S
mov cl,byte ptr [bx]
jcxz @@4
inc cl
lds si,S ; Load string address
les di,ResStr ; Load result address
cld ; Forward string-ups
@@3: lodsb ; Load a character
stosb ; Copy a character
loop @@3 ; Loop for all characters
push es
pop ds
mov bx,offset ResStr
mov cl,byte ptr [bx]
inc bx
@@1: mov al,[bx] ; Get a character
cmp al,'a'
jb @@2 ; < 'a', then jump
cmp al,'z'
ja @@2 ; > 'z', then jump
and al,5fh ; Converted to uppercase
mov [bx],al ; Store to string
@@2: inc bx ; Point to next character
loop @@1
@@4: pop ds ; Restore DS
pop bp ; Restore BP
retf 4 ; Remove parameter and return
; function LowerStr
Public LowerStr
ResStr EQU Dword ptr [bp+10]
S EQU Dword ptr [bp+6]
LowerStr:
push bp ; Save BP
mov bp,sp ; Save up stack frame
push ds ; Save DS
xor ch,ch
mov bx,offset S
mov cl,byte ptr [bx]
jcxz @@4
inc cl
lds si,S ; Load string address
les di,ResStr ; Load result address
cld ; Forward string-ups
@@3: lodsb ; Load a character
stosb ; Copy a character
loop @@3 ; Loop for all characters
push es
pop ds
mov bx,offset ResStr
mov cl,byte ptr [bx]
inc bx
@@1: mov al,[bx] ; Get a character
cmp al,'A'
jb @@2 ; < 'A', then jump
cmp al,'Z'
ja @@2 ; > 'Z', then jump
or al,20h ; Converted to lowercase
mov [bx],al ; Store to string
@@2: inc bx ; Point to next character
loop @@1
@@4: pop ds ; Restore DS
pop bp ; Restore BP
retf 4 ; Remove parameter and return
END
程序3：ASTRDEMO.PAS
{-----------------------------------}
{ ASTRDEMO.PAS }
{ Demonstrates the usage of ASTR }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
program AStrDemo;
Uses AStr;
var
s1, s2: string;
n1 : integer;
procedure UpLowDemo;
var
i : integer;
begin
s1 := '';
for i := 1 to 26 do s1 := s1 + chr(96+i);
S2 := UpperStr(s1);
Writeln('Upper : ', s2);
Writeln('Lower : ', LowerStr(s2));
end;
procedure HexStrDemo;
var
i,j : integer;
begin
Writeln('Print ASCII code, DEX|HEX');
i := 0;
repeat
for j := 1 to 5 do
begin
inc(i);
Write(IntToStr(i,3),'|',HexStr(i,1),'|',chr(i),Space(2));
if i=255 then
begin
Writeln;
exit;
end;
end;
Writeln;
until i = 255;
end;
procedure DateTimeDemo;
begin
writeln('Today is ',DateStr,Space(2),TimeStr);
end;
var ch : char;
num : longint;
s : string;
begin
UpLowDemo;
HexStrDemo;
DateTimeDemo;
end.
§2.3 磁盘输入输出单元DISK
磁盘输入输出单元DISK是专门处理与磁盘有关的过程和函数的集合，包括读写磁盘物理扇区过程、读写硬盘主引导记录过程、读写磁盘启动扇区过程、测试磁盘状态函数、取当前盘的物理磁盘号函数、检测磁盘是否准备好的函数。另外，还定义了3个与磁盘结构有关的数据结构。
§2.3.1 DISK单元定义的数据结构
DISK单元定义了三类数据结构，即主引导记录类型、分区表类型、BOOT记录类型，下面具体介绍记录类型的字段及其含义。
1.分区表类型PartitionType
分区表类型PartitionType的定义参见程序1，利用它可直接读取和修改硬盘的分区信息。PartitionTyped的各字段的意义及取值如下:
BootIndicator为启动标志，可取0或128，1字节；128代表活动分区，否则为非活动分区；
StartHead为分区开始的头数，1字节；
StartSector为分区开始的扇区数，1字节；
StartCylinder为分区开始的柱体数，1字节；
SysIndicator为系统标志，可取0(无定义)，1(DOS-12)，4(DOS-16)，5(EXTENDED)，6(BIGDOS)等值，1字节；
EndHead为分区结束头数，1字节；
EndSector为分区结束扇区数，1字节；
EndCylinder为分区结束柱体数，1字节；
RelativeSector为相对扇区数，双字；
TotalSector为扇区总数，双字。
2.主引导记录类型MBRT
MBRT的定义见程序1，其中各字段的意义及取值如下:
MainBoot为主引导程序及出错信息，占446个字节，察看其内容可以发现计算机是否感染主引导型病毒；
PartitionTable为硬盘分区信息表，是分区记录类型PartitionType一维数组，占64个字节；
Token为系统启动的有效标志，及55AAH。
3.BOOT记录类型BRT
BRT的定义见程序1，其中各字段的意义及取值如下:
pro1为转跳指令，3个字节；
ID为厂商标志字段，8个字节；
SS为扇区长度，一般为512，1个字；
AU为分配单元，及每簇的扇区数，1个字节；
RS为保留扇区数，1个字；
NF为FAT个数，一般为2，1个字节；
DS为根目录包含文件数，1个字；
TS为总扇区数，1个字；
MD为磁盘介质描述符，1个字节；
FS为每个FAT所占扇区数，1个字；
ST为每道所含扇区数，1个字；
NH为磁头数，1个字；
HS为隐含扇区个数，一般用于硬盘分区，1个字；
XX未用，1个字;
BS为大DOS分区扇区，双字;
PD为物理磁盘号，1个字;
ES为扩展启动记录标志，1字节;
VS为卷系列数，双字;
VL为卷标，11个字节;
FI为系统标志字符串，与分区表类型的系统标志相对应，8个字节;
prog启动代码区，占452个字节。
§2.3.2 DISK的函数和过程
1.ProcessPhysicalSector过程
功 能 读写磁盘物理扇区
用 法 ProcessPhysicalSector(OperateType: byte; DriveType: byte;
HeadNo: byte; StartCyl: byte; StartSec: byte;
SectorNumber: byte; var p)
说 明 OperateType为磁盘操作方式，2为读盘，3为写盘，字节型
DriveType为磁盘号，A盘为0，B盘为1，C盘为128，字节型
HeadNo为开始头数，字节型
StartCyl为开始柱体数，字节型
StartSec为开始扇区数，字节型
SectorNumber为待读、写扇区数，字节型
p为磁盘操作缓冲区，无类型变参
2.ReadMainBootRec过程
功 能 读硬盘主引导记录
用 法 ReadMainBootRec(StartCyl,StartSec: byte;var p : MBRT)
说 明 StartCyl为开始柱体数，字节型
StartSec为开始扇区数，字节型
p为磁盘缓冲区，类型为MBRT的变参
3.WriteMainBootRec过程
功 能 写硬盘主引导记录
用 法 WriteMainBootRec(StartCyl,StartSec: byte;var p: MBRT)
说 明 StartCyl为开始柱体数，字节型
StartSec为开始扇区数，字节型
p为磁盘缓冲区，类型为MBRT的变参
4.ReadBootSector过程
功 能 读启动扇区
用 法 ReadBootSector(Drive,StartHead,StartCyl,StartSec:byte;
var p:BRT)
说 明 Drive为磁盘号，A盘为0，B盘为1，C盘为128，字节型
StartHead为开始头数，字节型
StartCyl为开始柱体数，字节型
StartSec为开始扇区数，字节型
p为磁盘操作缓冲区，类型为BRT的变参
5.WriteBootSector过程
功 能 写启动扇区
用 法 WriteBootSector(Drive,StartHead,StartCyl,StartSec:byte;
var p:BRT);
说 明 参数意义同ReadBootSector
6.GetMediaByte函数
功 能 取当前磁盘介质描述符
用 法 GetMediaByte
结果类型 字节型
返 回 值 磁盘介质描述符，有如下取值:
FFH为320K 5.25"软盘
FEH为160K 5.25"软盘
FDH为360K 5.25"软盘
FCH为180K 5.25"软盘
F9H为1.2M 5.25"软盘或720K 3.5"软盘
F8H为硬盘
F0H为1.44M 3.5"软盘
7.GetDriveNo函数
功 能 取当前物理磁盘号
用 法 GetDriveNo
结果类型 字节型
返 回 值 当前物理磁盘号，0为A盘，1为B盘，128为C盘
8.DriveCase函数
功 能 测试软磁盘状态
用 法 DriveCase(DriveNo : byte)
结果类型 字节型
说 明 DriveNo为物理磁盘号。
返 回 值 软磁盘状态，0为正常，2为未关磁盘机门，12为磁盘未格式化, 255为非法驱动器
9.AutoKnow过程
功 能 自动感知盘片准备好与否
用 法 AutoKnow(Drive,Mode : byte);
说 明 Drive为驱动器号，0指A驱，1指B驱；Mode指A或B驱和盘片的类型， 03代表1.2MB驱动器中放有1.2MB软盘
§2.3.3 DISK的使用
DISKDEMO演示了DISK单元部分过程的用法。
§2.3.4 源程序清单
程序1:DISK.PAS
{***********************************}
{ UNIT : DISK }
{ Disk In/Out unit }
{ Written by Dong Zhanshan }
{ Version : July 1994 }
{***********************************}
unit Disk;
{$D-,S-}
interface
type
PartitionType = record
BootIndicator : Byte;
StartHead : Byte;
StartSector : Byte;
StartCylinder : Byte;
SysIndicator : Byte;
EndHead : Byte;
EndSector : Byte;
EndCylinder : Byte;
RelativeSector : longint;
TotalSector : longint;
end;
MBRT = record
MainBoot : array[0..445] of byte;
PartitionTable : array[1..4] of PartitionType;
Token : array[1..2] of byte;
end;
BRT = record
pro1 : array[1..3] of byte;
ID : array[1..8] of char;
SS : word; { bytes per sector }
AU : byte; { sectors per cluster }
RS : word; { Reserved sectors at begining}
NF : byte; { FAT copies }
DS : word; { root directory entries }
TS : word; { total sectors on disk }
MD : byte; { media descriptor byte }
FS : word; { sectors per FAT }
ST : word; { sectors per track }
NH : word; { sides }
HS : word; { hiden sectors }
{ extended parts of boot record }
XX : word; { unused word }
BS : longint; { big total number of sectors }
PD : word; { physical drive number }
ES : byte; { extended boot record signature }
VS : longint; { volume serial number }
VL : array[1..11] of char; { volume label }
FI : array[1..8] of char; { file system ID }
prog : array[1..452] of byte;
end;
Procedure ProcessPhysicalSector(OperateType: byte; DriveType: byte;
HeadNo: byte; StartCyl: byte; StartSec: byte;
SectorNumber: byte; var p) ;
procedure ReadMainBootRec(StartCyl,StartSec : byte;var p : MBRT);
procedure WriteMainBootRec(StartCyl,StartSec : byte;var p : MBRT);
procedure ReadBootSector(Drive,StartHead,StartCyl,StartSec:byte;var p:BRT);
procedure WriteBootSector(Drive,StartHead,StartCyl,StartSec:byte;var p:BRT);
function GetMediaByte:byte;
function GetDriveNo:byte;
function DriveCase(DriveNo : byte) : byte;
implementation
{$L DISK.OBJ}
Procedure ProcessPhysicalSector;external {DISK};
{$F+}
procedure ReadMainBootRec;
begin
ProcessPhysicalSector(2,$80,1,StartCyl,StartSec,1,p);
end;
procedure WriteMainBootRec;
begin
ProcessPhysicalSector(3,$80,1,StartCyl,StartSec,1,p);
end;
procedure ReadBootSector;
begin
ProcessPhysicalSector(2,Drive,StartHead,StartCyl,StartSec,1,p);
end;
procedure WriteBootSector;
begin
ProcessPhysicalSector(3,Drive,StartHead,StartCyl,StartSec,1,p);
end;
{$F-}
function GetMediaByte;external {DISK};
function GetDriveNo;external {DISK};
function DriveCase;external {DISK};
end.
程序2:DISK.ASM
; DISK.ASM
; Assembler including file for DISK.PAS unit
TITLE DISK
LOCALS @@
DOSSEG
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
; function DriveCase
PUBLIC DriveCase
DriveCase:
PUSH BP
MOV BP,SP
PUSH DS
MOV AL,BYTE PTR [BP+6]
MOV AH,0
MOV CX,1
MOV DX,0
MOV BX,OFFSET CS:BUF
PUSH CS
POP DS
INT 25H
JC @@1
MOV AL,0
@@1: ADD SP,2
POP DS
POP BP
RETF 2
BUF DB 512 DUP(0)
; function GetMediaByte;
PUBLIC GetMediaByte
GetMediaByte:
PUSH DS
MOV AH,1BH
INT 21H
MOV AX,DS:BX
POP DS
RETF
; function GetDriveNo;
PUBLIC GetDriveNo
GetDriveNo:
MOV AH,19H
INT 21H
RETF
; Procedure ProcessPhysicalSector;
PUBLIC ProcessPhysicalSector
ProcessPhysicalSector:
push bp
mov bp,sp
push es
mov ax,[bp+08]
mov es,ax
mov bx,[bp+06]
mov ch,byte ptr [bp+0eh]
mov cl,byte ptr [bp+0ch]
mov dh,byte ptr [bp+10h]
mov dl,byte ptr [bp+12h]
mov ah,byte ptr [bp+14h]
mov al,byte ptr [bp+0ah]
int 13h
pop es
pop bp
retf 12h
END
程序3:DISKDEMO.PAS
{-----------------------------------}
{ DISKDEMO.PAS }
{ Demonstrates the usage of DISK }
{ Written by Dong Zhanshan }
{ Version : July 1994 }
{-----------------------------------}
program DiskDemo;
uses acrt,disk;
const
MBRF = 'MRECORD.SAV';
BRF = 'BOOT.SAV';
var
f1 : file;
procedure ReadBootDemo;
var B : BRT;
begin
ProcessPhysicalSector(2,$80,1,0,1,1,MR);
assign(f1,BRF);
rewrite(f1,1);
blockwrite(f1,b,512);
close(f1);
end;
procedure ReadMainRecordDemo;
var MR : MBRT;
begin
ProcessPhysicalSector(2,$80,0,0,1,1,MR);
assign(f1,MBRF);
rewrite(f1,1);
blockwrite(f1,MR,512);
close(f1);
end;
begin
if YesNo('Read the main boot record in hard disk') then
ReadMainRecordDemo;
if YesNo('Read the boot record in hard disk') then
ReadBootDemo;
end.
§2.4 热键(Hotkey)单元POPUP
POPUP单元中定义的3个过程，1个用来定义热键过程，其余2个用来允许或禁止在程序中使用热键。该单元的基本原理是：用键盘中断来捕获热键，用时钟中断来启动热键过程，在一个热键过程活动期间，不能启动另一个热键过程。使用本单元，在程序中可以定义100个热键过程。
§2.4.1 POPUP的函数和过程
1.PopUpProc过程
功 能 定义热键过程
用 法 PopUpProc(Pr: Pointer; SC,KM: Byte)
说 明 Pr为热键过程的入口地址，指针类型
SC为热键的扫描码
KM为键盘状态字节的值，可取以下值:
1为按下右SHIFT键
2为按下左SHIFT键
4为按下CTRL键
8为按下ALT键
16为ScrollLock键有效
32为NumLock键有效
64为CapsLock键有效
128为Ins键有效
2.EnablePop过程
功 能 允许使用热键
用 法 EnablePop
3.DisablePop过程
功 能 禁止使用热键
用 法 DisablePop
§2.4.2 POPUP的使用
POPDEMO.PAS演示了POPUP单元的使用方法。
§2.4.3 源程序清单
程序1:POPUP.PAS
{*********************************************}
{ UNIT : POPUP }
{ Popupa (HOTKEY) Procedure Interface Unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{*********************************************}
Unit PopUp;
{$D-,S-}
interface
uses DOS;
procedure PopUpProc(Pr: Pointer; SC,KM: Byte);
procedure EnablePop;
procedure DisablePop;
Implementation
const
TimerInt = $1C;
KbdInt = $9;
CritInt = $24;
PopFlag: Boolean = False; { True when press HOTKEY }
Running: Boolean = False; { True when program is actival }
ScanCode: Byte = 0; { Scan Code for HOTKEY }
KeyMask: Byte = 0; { KeyBoard State byte }
MaxHotKey: Byte = 0; { Maximum numbers of HotKey }
type
HotKeyRec = record
Proc: Pointer;
Scancode: Byte;
KeyMask: Byte;
end;
var
TimerVec,KbdVec,OldCritVec: Pointer; { Save old vector }
PopRtn: Pointer; { Popup procedure pointer}
SaveBreak,TsrByte,
DOSSEG, { Start segment of DOS system }
INDOS:Word; { Busy mark of the DOS }
HotKey: Array[1..100] of HotKeyRec;
ScanCodeSet: Set of Byte;
procedure CLI; Inline($FA);
procedure STI; Inline($FB);
procedure NewCrit(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:Word);
Interrupt;
begin AX:=0; end;
procedure CallOldInt(Sub: Pointer); { Call the old INT }
begin
Inline( $9C/ { PUSHF }
$FF/$5E/$04); { CALL DWORD PTR [BP+4] }
end;
procedure CallPopProc(Sub: Pointer);
begin
Running := True;
Inline($FF/$5E/$04); { CALL Dword Ptr [BP+4] }
Running := False;
end;
procedure Clock(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:Word);
Interrupt;
begin
CallOldInt(TimerVec);
if (PopFlag) and (mem[DOSSeg:INDOS] = 0) then
begin
CLI;
Port[$20] := $20;
STI;
PopFlag := False;
CallPopProc(PopRtn);
end;
end;
procedure KeyBoard(Flags,CS,IP,AX,BX,CX,DX,SI,DI,DS,ES,BP:Word);
Interrupt;
var
SC: Byte;
procedure CheckKey;
var I : word;
begin
if (Port[$60] in ScanCodeSet) then
begin
SC := Port[$60];
for I := 1 to MaxHotKey do
if SC = HotKey[I].ScanCode then
begin
ScanCode := HotKey[I].ScanCode;
KeyMask := HotKey[I].KeyMask;
PopRtn := HotKey[I].Proc;
end;
end;
end;
begin
CheckKey;
if ((Port[$60]=ScanCode ) and ((mem[$0040:$0017]
and KeyMask) = KeyMask)) then
begin
TSRByte := Port[$61];
Port[$61] := TSRByte or $80;
Port[$61] := TSRByte;
CLI;
Port[$20] := $20;
STI;
if not Running then PopFlag := true;
end
else
CallOldInt(KbdVec);
end;
procedure EnablePop;
begin
inline($b4/$34/
$cd/$21/
$8c/$06/DOSSeg/
$89/$1e/INDOS); { save INDOS address }
GetIntVec(TimerInt,TimerVec);
GetIntVec(KbdInt,KbdVec);
GetIntVec(CritInt,OldCritVec);
SetIntVec(CritInt,@NewCrit);
SetIntVec(TimerInt,@Clock);
SetIntVec(KbdInt,@KeyBoard);
SetIntVec($1B,SaveInt1B);
end;
Procedure PopUpProc(PR: Pointer; SC,KM: Byte);
begin
inc(MaxHotKey);
with HotKey[MaxHotKey] do
begin
ScanCode := SC;
KeyMask := KM;
Proc := PR;
end;
ScanCodeSet := ScanCodeSet + [SC];
end;
procedure DisablePop;
var
P: Pointer;
begin
SetIntVec(TimerInt,TimerVec);
SetIntVec(KbdInt,KbdVec);
SetIntVec(CritInt,OldCritVec);
end;
begin
fillChar(HotKey,SizeOf(HotKey),#0);
ScanCodeSet := [];
end.
程序2:POPDEMO.PAS
{-----------------------------------}
{ POPDEMO.PAS }
{ Demonstrates the usage of POPUP }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
{$F+} { procedures must be called by far call }
program PopupDemo;
uses dos,crt,popup;
var ch : char;
procedure PopUpProc1;
begin
clrscr;
textattr := 2*16+15;
repeat
writeln('Popup procedure 1');
writeln('Please enter a key');
writeln('Enter ESC to quit this procedure');
ch := readkey;
writeln('Your entered key is ',ch);
until ch=#27;
textattr := 15;
end;
procedure PopUpProc2;
begin
clrscr;
textattr := 1*16+14;
repeat
writeln('Popup procedure 2');
writeln('Please enter a key');
writeln('Enter ESC to quit this procedure');
ch := readkey;
writeln('Your entered key is ',ch);
until ch=#27;
textattr := 15;
end;
begin
PopUpProc(@PopupProc1,$3b,$08);
PopUpProc(@PopupProc2,$3c,$08);
EnablePop;
repeat
writeln('Please enter a key, Enter ESC to quit');
ch := readkey;
writeln('Your entered key is :',ch);
until ch = #27;
DisablePop;
end.
§2.5 数据库交互单元DBASE
为了使TURBO PASCAL程序方便地与数据库软件DBASE Ⅲ、FOXBASE交互,编写了此单元。该单元共含有3个通用过程，一个用于打开并读取数据库文件的库结构信息,一个用于关闭数据库文件，另一个用于读取DBASE数据库文件的记录。该单元也定义了几个数据类型。
§2.5.1 DBASE单元的数据类型和常量
1.字段类型FieldType
FldName为字段名，10字节字符串型
FldType为字段类型，字符型
FldOffset为字段在记录中的位置，字型
FldWidth为字段宽度，字节型
PosDec为数字型字段的小数点位置，字节型
2.字段类型数组及其指针
每条记录最多有128个字段，所以FieldTypeArray为128个FieldType类型元素的一维数组；FieldTypePtr为FieldTypeArray类型的指针类型；
3.数据库结构信息类型StrucType
NumRec为记录个数，长整型
StartPosData为记录数据的开始位置，字型
LengthRec为每条记录的长度，字型
NumField为每条记录的字段数，字节型
Field为数据库字段指针，FieldTypePtr类型
4.记录类型数组及其指针
每条记录最多有4000个字符,所以RecTypeArray为4000个char类型元素的一维数组;RecTypePtr为RecTypeArray对应的指针类型;
§2.5.2 DBASE单元的过程和函数
1.OpenDBase过程
功 能 打开指定名字的DBASE数据库，并读取其结构信息
用 法 OpenDBase(DbfName : string; var dbf : file;
var RecInfo : StrucType)
说 明 DbfName为字符串类型, 代表数据库文件名, 必须包括扩展名
dbf为无类型文件变量
RecInfo为数据库结构信息变量，StrucType类型
2.ReadRecord过程
功 能 读数据库记录
用 法 ReadRecord(var dbf : file; RecNo : longint;
RecInfo : StrucType; var Rec : RecTypePtr)
说 明 dbf为无类型文件变量
RecNo为记录号，长整类型
RecInfo为数据库结构信息，StrucType类型
Rec为记录变量，RecTypePtr类型
3.CloseDBase过程
功 能 关闭数据库文件
用 法 CloseDBase(var dbf : file; RecInfo : StrucType)
说 明 dbf为无类型文件变量
RecInfo为数据库结构信息，StrucType类型
§2.5.3 DBASE数据库单元的使用
首先，用OpenDBase打开数据库文件，并读取数据库的结构, 然后用ReadRecord随机读取数据库的任何记录，数据库使用完后，用CloseDBase关闭数据库文件。关于DBASE单元的使用由DBDEMO.PAS来演示，另外还可以参考§3.9节的数据库打卡程序PDBC.PAS
§2.5.4 源程序清单
程序1:DBASE.PAS
{ DBASE.PAS 1.0 }
{ Copyright (c) 1994 Dong Zhanshan }
Unit DBase;
interface
type
FieldType = record
FldName : string[10];
FldType : char;
FldOffset : word;
FldWidth : byte;
PosDec : byte;
end;
{ 每条记录最多有128个字段 }
FieldTypeArray = array[1..128] of FieldType;
FieldTypePtr = ^FieldTypeArray;
StrucType = record
NumRec : longint;
StartPosData : word;
LengthRec : word;
NumField : byte;
Field : FieldTypePtr;
end;
{ 每条记录最多有4000个字符 }
RecTypeArray = Array[1..4000] of char;
RecTypePtr = ^RecTypeArray;
procedure OpenDBase(DbfName : string; var dbf : file;
var RecInfo : StrucType);
procedure ReadRecord(var dbf : file; RecNo : longint;
RecInfo : StrucType; var Rec : RecTypePtr);
procedure CloseDBase(var dbf : file; RecInfo : StrucType);
implementation
procedure CloseDBase;
begin
close(dbf);
with RecInfo do Freemem(Field,NumField*32);
end;
procedure OpenDBase;
var i,j,l : integer;
ab : array[1..32] of byte;
begin
assign(dbf,DbfName);
reset(dbf,1);
blockread(dbf,ab,12);
with RecInfo do
begin
NumRec := ab[5] + ab[6] * 256 + ab[7] * 256 *256
+ ab[8] * 256 * 256;
StartPosData := ab[9] + ab[10] * 256;
LengthRec := ab[11] + ab[12] * 256;
NumField := (StartPosData - 33) div 32;
getmem(Field,NumField*Sizeof(FieldType));
seek(dbf,32);
for i := 1 to NumField do
begin
blockread(dbf,ab,32);
l := 0;
for j := 1 to 10 do if ab[j] <> 0 then inc(l);
with Field^[i] do
begin
move(ab[1],FldName[1],l);
FldName[0] := char(l);
FldType := chr(ab[12]);
FldWidth := ab[17];
PosDec := ab[18];
if i = 1 then FldOffset := 0
else
begin
FldOffset := Field^[1].FldWidth;
for j := 2 to i - 1 do
FldOffset := FldOffset + Field^[j].FldWidth;
end;
end;
end;
end;
end;
procedure ReadRecord;
var ch : char;
begin
with RecInfo do
begin
seek(dbf,StartPosData + LengthRec * (RecNo-1) );
blockread(dbf,ch,1);
blockread(dbf,Rec^,LengthRec);
end;
end;
end.
程序2:DBDEMO.PAS
{-----------------------------------}
{ DBDEMO.PAS }
{ Written by Dong Zhanshan }
{ Version : Oct. 1994 }
{-----------------------------------}
program DbDemo;
uses Dbase;
var
RecInfo : StrucType;
Rec : RecTypePtr;
f1 : file;
procedure DisplayStruc(RecInfo : StrucType);
var i : word;
begin
with RecInfo do
begin
Writeln('Number of Records : ',NumRec);
Writeln('Length of a Record : ',LengthRec);
Writeln('Number of Field : ',NumField);
Writeln(' Name Type Width Dec');
for i := 1 to NumField do
with Field^[i] do
Writeln(FldName:10,FldType:4,FldWidth:8,PosDec:7);
end;
end;
begin
OpenDBase('tra.dbf', f1, RecInfo);
DisplayStruc(RecInfo);
CloseDBase(f1, RecInfo);
end.
§2.6 扩展内存使用单元EMS
扩展内存使用单元是专门处理与扩展内存的检测、分配、使用、释放等有关的过程和函数以及数据类型的集合。它包括了1个新的数据类型、8个函数和1个过程。
§2.6.1 扩展内存单元的数据类型
该单元定义了一个与数据在扩展内存与常规内存之间传送有关的类型EMBStruc,其字段及其含义如下：
count为待转送数据的字节数，长整型
SrcType源类型，字节型；0代表常规内存，1代表扩展内存
SrcHandle源句柄；字型；0代表常规内存，非零代表扩展内存
SrcOffset源地址偏移；字型
SrcSegment源段地址；字型
DesType目的类型，字节型；0代表常规内存，1代表扩展内存
DesHandle目的句柄；字型；0代表常规内存，非零代表扩展内存
DesOffset目的地址偏移；字型
DesSegment目的段地址；字型
§2.6.2 扩展内存单元的过程和函数
1.EMMtest函数
功 能 检测是否存在EMM驱动程序
用 法 EMMtest
结果类型 布尔型
返 回 值 EMM存在返回TRUE,不存在返回FALSE
2.EMSstat函数
功 能 当EMM存在时,检测EMM的状态
用 法 EMSstat
结果类型 布尔型
返 回 值 EMM无错误,返回TRUE,否则返回FALSE
3.EMSVer函数
功 能 取EMM版本号
用 法 EMSVer
结果类型 字节型
返 回 值 返回一字节的版本号,高4位是BCD码的主版本号,低4位是BCD码的次版本号
4.EMBFree函数
功 能 释放已分配的扩展内存块
用 法 EMBFree( Handle : word)
结果类型 布尔型
说 明 Handle为扩展内存句柄,字型
返 回 值 释放成功,返回TRUE,否则返回FALSE
5.EMBAlloc函数
功 能 分配扩展内存块
用 法 EMBAlloc( nbytes : longint)
结果类型 字型
说 明 nbytes为欲分配扩展内存块的字节数
返 回 值 分配成功,返回扩展内存句柄,否则返回0
6.EMSPage过程
功 能 获取EMS的页计数
用 法 EMSPage(Var TotalPage, LeftPage : word)
说 明 TotalPage和LeftPage均为字型变量,TotalPage代表EMS的总页数, LeftPage代表EMS的可用页数
7.EMSFrame函数
功 能 获取EMS的页框段地址
用 法 EMSFrame
结果类型 字型
返 回 值 EMS页框的段地址
8.EMBGet函数
功 能 从扩展内存取回数据
用 法 EMBGet(var arr; nbytes : longint; Handle : word)
结果类型 布尔型
说 明 arr为无类型变量,作数据缓冲区用; nbytes为常整型,传送数据的长度; Handle为字型,为扩展内存句柄
返 回 值 取数据成功返回TRUE,否则返回FALSE
9.EMBPut函数
功 能 向扩展内存传送数据
用 法 EMBPut(var arr; nbytes : longint; Handle : word)
结果类型 布尔型
说 明 arr为无类型变量,作数据缓冲区用; nbytes为常整型,传送数据的长度; Handle为字型,为扩展内存句柄
返 回 值 传送数据成功返回TRUE,否则返回FALSE
§2.6.3 扩展内存单元的使用
EMSDEMO.PAS演示了EMS单元的使用。程序首先用EMMTest检测是否存在EMM程序，存在则调用EMSPage和EMSVer显示EMS内存的多少和EMM的版本号，然后分配能容纳10000个实数的扩展内存，将数组ARR中的10000个实数传送到扩展内存，将ARR数组置零，从扩展内存取回10000个实数放入ARR中，显示ARR中的10000个数据，最后，释放申请的扩展内存。
§2.6.4 源程序清单
程序1:EMS.PAS
{************************************}
{ UNIT : EMS }
{ Written by Dong Zhanshan }
{ Version : Sept.1994 }
{************************************}
unit EMS;
interface
type
EMBStruc = record
count : longint;
SrcType : byte;
SrcHandle : word;
SrcOffset : word;
SrcSegment : word;
DesType : byte;
DesHandle : word;
DesOffset : word;
DesSegment : word;
end;
function EMMtest : boolean;
function EMSstat : boolean;
function EMSVer : byte;
function EMBFree( Handle : word) : boolean;
function EMBAlloc( nbytes : longint) : word;
procedure EMSPage(Var TotalPage, LeftPage : word);
function EMSFrame : word;
function EMBGet(var arr; nbytes : longint; Handle : word) : boolean;
function EMBPut(var arr; nbytes : longint; Handle : word) : boolean;
implementation
{$L ems.obj}
function EMMtest; external;
function EMSstat; external;
function EMSVer; external;
function EMBFree; external;
procedure EMSPage; external;
function EMSFrame; external;
function Alloc(n : word) : word; external;
function EMBMov(var EMB : EMBStruc) : boolean; external;
procedure DisplayEmsError(ErrorNo : byte);
const ErrorStr : array[1..14] of string[79] =
(('Size is invalid'),
('EMM driving routine is not installed'),
('EMM software failure'),
('EMS hardware failure'),
(''),
('Invalid handle'),
('Invalid function of EMM'),
('No available handle'),
(''),
('Applied pages are more than existing pages'),
('Applied pages are more than available pages'),
(''),
('No. of Pages is great than page of handle'),
('Invalid physical page'));
begin
if ErrorNo <> 0 then Writeln('Error : ',ErrorStr[ErrorNo - $7D]);
end;
function EMBAlloc;
var n : word;
begin
n := (nbytes + $3fff) div $4000;
EMBAlloc := Alloc(n);
end;
function EMBPut(var arr; nbytes : longint; Handle : word) : boolean;
var EMB : EMBStruc;
begin
with EMB do
begin
count := nbytes;
SrcType := 0;
SrcHandle := 0;
SrcOffset := ofs(arr);
SrcSegment := Seg(arr);
DesType := 1;
DesHandle := handle;
DesOffset := 0;
DesSegment := 0;
if EMBMov(EMB) then EMBPut := true else EMBPut := false;
end;
end;
function EMBGet(var arr; nbytes : longint; Handle : word) : boolean;
var EMB : EMBStruc;
begin
with EMB do
begin
count := nbytes;
SrcType := 1;
SrcHandle := handle;
SrcOffset := 0;
SrcSegment := 0;
DesType := 0;
DesHandle := 0;
DesOffset := Ofs(arr);
DesSegment := seg(arr);
if EMBMov(EMB) then EMBGet := true else EMBGet := false;
end;
end;
end.
程序2:EMS.ASM
TITLE EMS
DOSSEG
LOCALS @@
.MODEL TPASCAL
.CODE
ASSUME CS:@CODE
Extrn DisplayEmsError:near
DevName db 'EMMXXXX0'
; function EMMTest
public EMMTest
EMMTest:
push bp
mov bp,sp
push es
mov ax,3567h
int 21h
mov di,10
push ds
mov ax,cs
mov ds,ax
mov si,offset DevName
mov cx,8
rep cmpsb
pop ds
mov al,0
jne @@1
mov al,1
@@1: pop es
pop bp
retf
; function EMSStat
public EMSStat
EMSStat:
push bp
mov bp,sp
mov ah,40h
int 67h
mov al,ah
push ax
call DisplayEmsError
mov al,0
cmp ah,0
jne @@1
mov al,1
@@1: pop bp
retf
; Procedure EMSPage
public EMSPage
EMSPage:
push bp
mov bp,sp
push ds
mov ah,42h
int 67h
lds si,[bp+6] ; number of left pages
mov [si],bx ;
lds si,[bp+10] ; number of total pages
mov [si],dx ;
mov al,ah
push ax
call DisplayEmsError
pop ds
pop bp
retf 8
; function EMSFrame : word;
public EMSFrame
EMSFrame:
push bp
mov bp,sp
mov ah,41h
int 67h
mov al,ah
push ax
call DisplayEmsError
mov ax,bx
pop bp
retf
; function EMSVer
public EMSVer
EMSVer:
push bp
mov bp,sp
mov ah,46h
int 67h
push ax
mov al,ah
push ax
call DisplayEmsError
pop ax
pop bp
retf
; funtion Alloc
public Alloc
Alloc:
push bp
mov bp,sp
mov ah,43h
mov bx,[bp+6]
int 67h
push ax
mov al,ah
push ax
call DisplayEmsError
pop ax
mov ax,dx
pop bp
ret 2
; function EMBFree
public EMBFree
EMBFree:
push bp
mov bp,sp
mov dx,[bp+6]
mov ah,45h
int 67h
mov al,ah
push ax
call DisplayEmsError
mov al,0
cmp ah,0
jne @@1
mov al,1
@@1: pop bp
retf 2
; function EMBMov
public EMBMov
EMBMov:
push bp
mov bp,sp
push ds
push si
lds si,[bp+4]
mov ax,5700h
int 67h
mov al,ah
push ax
call DisplayEmsError
mov al,0
cmp ah,0
jne @@1
mov al,1
@@1: pop si
pop ds
pop bp
ret 4
end
程序3:EMSDEMO.PAS
{-----------------------------------}
{ EMSDEMO.PAS }
{ Demonstrates the usage of EMS }
{ Written by Dong Zhanshan }
{ Version : Sept.1994 }
{-----------------------------------}
program EMSDemo;
uses EMS;
const
size = 10000;
var ver,primever,secondver : byte;
ar : array[1..size] of real;
handle : word;
i,j : word;
begin
if EMMTest then
begin
EMSpage(i,j);
writeln('EMS Total pages := ',i,' Left Pages := ',j);
Ver := EMSVER;
Primever := (ver and 240) shr 4;
secondver := ver and 15;
writeln('EMS version : ',primever,'.',secondver);
handle := EmbAlloc(sizeof(ar));
writeln(handle);
for i := 1 to size do ar[i] := ln(i);
if EmbPut(ar,sizeof(ar),Handle) then writeln('Put EMS OK');
for i := 1 to size do ar[i] := 0;
if EmbGet(ar,sizeof(ar),Handle) then writeln('Get EMS OK');
for i := 1 to size do write(i:7,':',ar[i]:8:4);
if EMBFree(handle) then writeln('Free EMS OK!');
end
else
writeln('EMS does not exist');
end.
§2.7 扩充内存使用单元XMS
扩充内存使用单元包含了第一章所述扩充内存管理规范的各项功能，在TURBO PASCAL程序中只要使用此单元即可使用扩充内存。该单元定义了15个函数和1个过程，同时定义了3个记录类型，1个变量和4个常量。
§2.7.1 XMS单元所定义的数据结构
下面介绍XMS单元定义的3个记录数据类型、4个与A20地址线的状态有关的常量和1个存储XMS调用错误状态的变量ErrorStatus。
1.XMS状态记录类型XMS_status
version为版本号，字型
revision为内部版本号，字型
HMA_exist为高内存区是否存在的标志，布尔型
2.XMS内存状态记录类型XMS_mem_stat
LargestBlock为最大扩充内存分配块，以KB计，字型
TotalFreeMemory为总的自由扩充内存块，以KB计，字型
3.内存块传送参数结构类型EMBstruc
Count为传送的字节数，长整型
SourceHandle为源句柄，字型,0代表常规内存,非0代表扩充内存
SourceOfs为源偏移，长整型
DestinHandle为目的句柄，字型,0代表常规内存,非0代表扩充内存
DestinOfs为目的偏移，长整型
4.与A20地址线有关的4个常量
GlobalEnableA20为全程打开A20地址线功能
GlobalDisableA20为全程关闭A20地址线功能
LocalEnableA20为局部打开A20地址线功能
LocalDisableA20为局部关闭A20地址线功能
§2.7.2 XMS单元的过程和函数
1.XMS_test函数
功 能 检测XMM是否存在
用 法 XMS_test
结果类型 布尔型
返 回 值 如果XMM存在返回TRUE，否则返回FALSE
2.XMS_stat过程
功 能 检测XMM的状态
用 法 XMS_stat(var stat : XMS_status)
说 明 stat为XMS_status的变参
3.XMS_avail函数
功 能 取XMS的内存状态
用 法 XMS_avail(var MemStat : XMS_mem_stat)
结果类型 布尔型
说 明 MemStat为XMS_mem_stat类型的变参
返 回 值 如果XMS无错返回TRUE，否则返回FALSE
4.XMS_alloc函数
功 能 分配XMS内存
用 法 XMS_alloc(KSize : word; var Handle : word)
结果类型 布尔型
说 明 KSize为欲申请XMS内存的大小,以KB计,字型
Handle为XMS内存句柄,字型变量
返 回 值 分配成功返回TRUE,分配失败返回FALSE
5.XMS_realloc函数
功 能 重新分配XMS内存
用 法 XMS_realloc(KSize， Handle : word)
结果类型 布尔型
说 明 KSize为欲重新分配的XMS内存的大小,以KB计,字型值参
Handle为XMS内存句柄,字型值参
返 回 值 如果重新分配成功返回TRUE,否则返回FALSE
6.XMS_free函数
功 能 释放指定的XMS内存
用 法 XMS_free(Handle : word)
结果类型 布尔型
说 明 Handle为XMS内存句柄,字型值参
返 回 值 如果XMS内存释放成功返回TRUE,否则返回FALSE
7.XMS_lock函数
功 能 锁已分配的XMS内存
用 法 XMS_lock(Handle : word; var MyAddr : LongInt)
结果类型 布尔型
说 明 Handle为已分配XMS内存的句柄,字型值参
MyAddr为加锁的内存地址,长整型变参
返 回 值 如果加锁成功返回TRUE,否则返回FALSE
8.XMS_unlock函数
功 能 解锁锁定的XMS内存
用 法 XMS_unlock(Handle : word)
结果类型 布尔型
说 明 Handle为加锁的XMS内存的句柄,字型值参
返 回 值 如果解锁成功返回TRUE,否则返回FALSE
9.XMS_bstat函数
功 能 取扩充内存控制块句柄信息
用 法 XMS_bstat(Handle:word;var LockCount,NumFreeHandle:byte)
结果类型 布尔型
说 明 Handle为XMS内存句柄,字型值参
LockCount为加锁信息,字节型变参
NumFreeHandle为自由XMS内存句柄个数,字节型变参
返 回 值 如果已获得信息块返回TRUE,否则返回FALSE
10.XMS_move函数
功 能 移动扩充内存块
用 法 XMS_move(var EMB : EMBstruc)
结果类型 布尔型
说 明 EMB为EMBstruc类型的变量,为内存传送的参数块
返 回 值 如果内存之间的数据传送成功返回TRUE,否则返回FALSE
11.HMA_alloc函数
功 能 分配高内存区
用 法 HMA_alloc(Size : word)
结果类型 布尔型
说 明 Size为欲分配内存的大小,字型值参
返 回 值 如果分配成功返回TRUE,否则返回FALSE
12.HMA_free函数
功 能 释放高内存区
用 法 HMA_free
结果类型 布尔型
返 回 值 释放成功返回TRUE,否则返回FALSE
13.Alter_A20函数
功 能 操纵A20地址线
用 法 Alter_A20(Func : byte)
结果类型 布尔型
说 明 Func可取单元头上定义的4个常量中的一个,字节型值参
返 回 值 如果成功地执行了A20地址线的操作返回TRUE,否则返回FALSE
14.A20_stat函数
功 能 查询A20地址线的状态
用 法 A20_stat
结果类型 布尔型
返 回 值 查询成功返回TRUE,否则返回FALSE
15.UMB_alloc函数
功 能 分配上位存储块(UMB)
用 法 UMB_alloc(var PSize,SegAddr : word)
结果类型 布尔型
说 明 PSize为欲分配的UMB的大小,以KB计,字型变参
SegAddr为分配的UMB的段地址,字型变参
返 回 值 如果分配成功返回TRUE,否则返回FASLE
16.UMB_free函数
功 能 释放已分配的上位存储块(UMB)
用 法 UMB_free(SegAddr : word)
结果类型 布尔型
说 明 SegAddr为分配的UMB的段地址
返 回 值 如果释放成功返回TRUE,否则返回FLASE
§2.7.3 XMS单元的使用
XMSDEMO.PAS演示了XMS单元大多数函数的用法。首先用XMS_test检测XMM是否存在，如果存在调用XMS_stat取XMM的版本号，并显示之，而后取XMS的内存分配状态，最后演示了如何将数据传入与传出XMS内存。读者可以仿照此演示程序，编制自己的使用扩充内存的程序。
§2.7.4 源程序清单
程序1:XMS.PAS
{************************************}
{ UNIT : XMS }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{************************************}
unit XMS;
interface
Type
XMS_status = record
version,revision : word;
HMA_exist : boolean;
end;
XMS_mem_stat = record
LargestBlock,TotalFreeMemory : Word;
end;
EMBstruc = record
Count : LongInt;
SourceHandle : word;
SourceOfs : LongInt;
DestinHandle : word;
DestinOfs : LongInt;
end;
var
ErrorStatus : Byte;
Const
GlobalEnableA20 = 00;
GlobalDisableA20 = 01;
LocalEnableA20 = 02;
LocalDisableA20 = 03;
function XMS_test : boolean;
procedure XMS_stat(var stat : XMS_status);
function XMS_avail(var MemStat : XMS_mem_stat) : boolean;
function XMS_alloc(KSize : word; var Handle : word) : boolean;
function XMS_realloc(KSize, Handle : word) : boolean;
function XMS_free(Handle : word) : boolean;
function XMS_lock(Handle : word; var MyAddr : LongInt) : boolean;
function XMS_unlock(Handle : word) : boolean;
function XMS_bstat(Handle : word; var LockCount, NumFreeHandle : byte) : boolean;
function XMS_move(var EMB : EMBstruc) : boolean;
function HMA_alloc(Size : word) : boolean;
function HMA_free : boolean;
function Alter_A20(Func : byte) : boolean;
function A20_stat : boolean;
function UMB_alloc(var PSize,SegAddr : word) : boolean;
function UMB_free(SegAddr : word) : boolean;
implementation
uses DOS;
var
XMS_control : Pointer;
{$L XMS.OBJ}
function XMS_test : boolean;
external;
procedure XMS_stat(var stat : XMS_status);
external;
function XMS_avail(var MemStat : XMS_mem_stat) : boolean;
external;
function XMS_alloc(KSize : word; var Handle : word) : boolean;
external;
function XMS_realloc(KSize, Handle : word) : boolean;
external;
function XMS_free(Handle : word) : boolean;
external;
function XMS_lock(Handle : word; var MyAddr : LongInt) : boolean;
external;
function XMS_unlock(Handle : word) : boolean;
external;
function XMS_bstat(Handle : word; var LockCount, NumFreeHandle : byte) : boolean;
external;
function XMS_move(var EMB : EMBstruc) : boolean;
external;
function HMA_alloc(Size : word) : boolean;
external;
function HMA_free : boolean;
external;
function Alter_A20(Func : byte) : boolean;
external;
function A20_stat : boolean;
external;
function UMB_alloc(var PSize,SegAddr : word) : boolean;
external;
function UMB_free(SegAddr : word) : boolean;
external;
end.
程序2:XMS.ASM
; XMS.ASM 1.0
; used by XMS.PAS
TITLE XMS
LOCALS @@
DOSSEG
.MODEL TPASCAL
extrn XMS_control:DWORD
extrn ErrorStatus:BYTE
.CODE
ASSUME CS:@CODE
; function XMS_test
PUBLIC XMS_test
XMS_test:
push bp
mov bp,sp
mov ax,4300h
int 2fh
cmp al,80h
jnz @@1
mov ax,4310h
int 2fh
mov word ptr XMS_control,bx
mov word ptr XMS_control+2,es
mov al,01
jmp @@2
@@1: mov al,0
@@2: mov sp,bp
pop bp
retf
; procedure XMS_stat
PUBLIC XMS_stat
XMS_stat:
push bp
mov bp,sp
mov ah,0
call XMS_control
les si,[bp+6]
mov es:[si],ax
mov es:[si+2],bx
mov es:[si+4],dl
pop bp
retf 04
; function XMS_avail
PUBLIC XMS_avail
XMS_avail:
push bp
mov bp,sp
mov ah,8
call XMS_control
les si,[bp+6]
mov es:[si],ax
mov es:[si+2],dx
mov ErrorStatus,bl
pop bp
retf 04
; function XMS_alloc
PUBLIC XMS_alloc
XMS_alloc:
push bp
mov bp,sp
mov ah,9
mov dx,[bp+0ah]
call XMS_control
les si,[bp+6]
mov es:[si],dx
mov ErrorStatus,bl
pop bp
retf 06
; function XMS_realloc
PUBLIC XMS_realloc
XMS_realloc:
push bp
mov bp,sp
mov ah,0fh
mov bx,[bp+8]
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 4
; function XMS_lock
PUBLIC XMS_lock
XMS_lock:
push bp
mov bp,sp
mov ah,0ch
mov dx,[bp+0ah]
call XMS_control
les si,[bp+6]
mov es:[si],bx
mov es:[si+2],dx
mov ErrorStatus,bl
pop bp
retf 06
; function XMS_unlock
PUBLIC XMS_unlock
XMS_unlock:
push bp
mov bp,sp
mov ah,0dh
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 02
; function XMS_bstat
PUBLIC XMS_bstat
XMS_bstat:
push bp
mov bp,sp
mov ah,0eh
mov dx,[bp+0eh]
call XMS_control
les si,[bp+0ah]
mov byte ptr es:[si],bh
les si,[bp+6]
mov byte ptr es:[si],bl
mov ErrorStatus,bl
pop bp
retf 0ah
; function XMS_move
PUBLIC XMS_move
XMS_move:
push bp
mov bp,sp
xor bx,bx
mov ah,0bh
push ds
pop es
push ds
lds si,[bp+6]
call es:XMS_control
pop ds
mov ErrorStatus,bl
pop bp
retf 04
; function XMS_free
PUBLIC XMS_free
XMS_free:
push bp
mov bp,sp
mov ah,0ah
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 02
; function HMA_alloc
PUBLIC HMA_alloc
HMA_alloc:
push bp
mov bp,sp
mov ah,1
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 02
; function HMA_free
PUBLIC HMA_free
HMA_free:
push bp
mov bp,sp
mov ah,2
call XMS_control
mov ErrorStatus,bl
pop bp
retf
; function Alter_A20
PUBLIC Alter_A20
Alter_A20:
push bp
mov bp,sp
mov ah,[bp+6]
add ah,3
call XMS_control
mov ErrorStatus,bl
pop bp
retf 2
; function A20_stat
PUBLIC A20_stat
A20_stat:
push bp
mov bp,sp
mov ah,7
call XMS_control
mov ErrorStatus,bl
pop bp
retf
; function UMB_alloc
PUBLIC UMB_alloc
UMB_alloc:
push bp
mov bp,sp
mov ah,10h
les si,[bp+0ah]
mov dx,es:[si]
call XMS_control
or ax,ax
jz @@5
les si,[bp+6]
mov es:[si],bx
@@5: les si,[bp+0ah]
mov es:[si],dx
mov ErrorStatus,bl
pop bp
retf 08
; function UMB_free
PUBLIC UMB_free
UMB_free:
push bp
mov bp,sp
mov ah,11h
mov dx,[bp+6]
call XMS_control
mov ErrorStatus,bl
pop bp
retf 2
end
程序3:XMSDEMO.PAS
{-----------------------------------}
{ XMSDEMO.PAS }
{ Demonstrates the usage of XMS }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{-----------------------------------}
program XMSDemo;
uses XMS;
var stat : XMS_status;
memstat : XMS_mem_stat;
handle : word;
emb : EMBstruc;
i,ksize : integer;
Myaddr : LongInt;
ar,ar1 : array[1..10000] of integer;
begin
if XMS_test then
begin
writeln('XMS memory exists');
XMS_stat(stat);
writeln('XMS v',hi(stat.version),' XMM v',hi(stat.revision),'.0',lo(stat.revision));
if XMS_Avail(Memstat) then
writeln('lb= ',memStat.LargestBlock,' TFM = ',memstat.TotalFreeMEmory);
if XMS_alloc(16,handle) then
writeln('Handle = ',handle);
if XMS_Avail(Memstat) then
writeln('lb= ',memStat.LargestBlock,' TFM = ',memstat.TotalFreeMEmory);
if XMS_free(handle) then writeln('free ok');
if XMS_Avail(Memstat) then
writeln('lb= ',memStat.LargestBlock,' TFM = ',memstat.TotalFreeMEmory);
if A20_stat then writeln('A20 is busy');
end;
for i := 1 to 10000 do ar[i] := i;
{ for i := 1 to 10000 do write(ar[i]:5); }
ksize := sizeof(ar) div 1024;
if odd(Ksize) then inc(Ksize);
if XMS_alloc(Ksize,handle) then
begin
writeln(ErrorStatus);
emb.count := 1024;
emb.SourceHandle := 0;
emb.destinHandle := handle;
for i:= 1 to Ksize do
begin
emb.destinOfs := (i-1)*1024;
emb.SourceOfs := longint(addr(ar))+(i-1)*1024;
if XMS_move(emb) then ;
end;
for i := 1 to 10000 do ar[i] := 0;
WRITELN(ERRORSTATUS);
emb.count := 1024;
emb.SourceHandle := handle;
emb.destinHandle := 0;
for i:= 1 to Ksize do
begin
emb.SourceOfs := (i-1)*1024;
emb.destinOfs := longint(addr(ar))+(i-1)*1024;
if XMS_move(emb) then ;
end;
for i := 1 to 10000 do write(ar[i]:5);
WRITELN(ERRORSTATUS);
end;
if XMS_free(handle) then writeln('OK !');
end.
§2.8 数学函数单元MATH
MATH单元是一些数学函数的集合，是对TURBO PASCAL数学函数的一个有益的补充。它包括：取符号函数、指数函数、对数函数、三角和反三角函数、最大最小函数、排列与组合函数、阶乘函数等。
§2.8.1 MATH的函数和过程
1.Sign函数
功 能 取实数的符号
用 法 Sign(x : real)
结果类型 整型
说 明 x为实型数
返 回 值 +1或-1
2.Power函数
功 能 求x攩y攪的值
用 法 Power(x,y : real)
结果类型 实型
说 明 x为基数，实数；y为指数，实数
返 回 值 x攩y攪的值
3.Log函数
功 能 求log攬x攭y的值
用 法 Log(x,y : real)
结果类型 实型
说 明 x为对数的底数，实数；y为对数的真数，实数
返 回 值 log攬x攭y的值
4.Amax函数
功 能 求两个实数中较大的数
用 法 Amax(mxn1, mxn2 : real)
结果类型 实型
说 明 mxn1，mxn2为实数
返 回 值 两个实数中较大的数
5.Amin函数
功 能 求两个实数中较小的数
用 法 Amin(mxn1, mxn2 : real)
结果类型 实型
说 明 参数意义同Amax
返 回 值数中较小的数
6.Max函数
功 能 求两个整数中较大的数
用 法 Max(mxn1, mxn2 : longint)
结果类型 长整型
说 明 mxn1，mxn2为两个长整数
返 回 值 两个整数中较大的数
7.Min函数
功 能 求两个整数中较小的数
用 法 Min(mxn1, mxn2 : longint)
结果类型 长整型
说 明 参数意义同Max
返 回 值 两个整数中较小的数
8.Tan函数
功 能 求角x的正切函数值
用 法 Tan(x : real)
结果类型 实型
说 明 x为角度值，以弧度计
返 回 值 角x的正切函数值
9.CTan函数
功 能 求角x的余切函数值
用 法 CTan(x : real)
结果类型 实型
说 明 x为角度值，以弧度计
返 回 值 角x的余切函数值
10.ArcSin函数
功 能 求数x的反正弦函数值
用 法 ArcSin(x : real)
结果类型 实型
说 明 x为在[-1,1]区间内的实数
返 回 值 数x的反正弦函数值，以弧度计
11.ArcCos函数
功 能 求数x的反余弦函数值
用 法 ArcCos(x : real)
结果类型 实型
说 明 x为在[-1,1]区间内的实数
返 回 值 数x的余正弦函数值，以弧度计
12.Comb函数
功 能 求组合C攬n攭攩m攪的值
用 法 Comb(n,m : word)
结果类型 长整型
说 明 n，m为两个正整数，m小于n
返 回 值 组合C攬n攭攩m攪的值
13.Permut函数
功 能 求排列P攬n攭攩m攪的值
用 法 Permut(n,m : word)
结果类型 长整型
说 明 n，m为两个正整数，m小于n
返 回 值 排列P攬n攭攩m攪的值
14.Factor函数
功 能 求正整数n的阶乘值
用 法 Factor(n : word)
结果类型 长整型
说 明 n为正整数
返 回 值 正整数n的阶乘值
§2.8.2 MATH的使用
MATHDEMO.PAS演示了MATH单元的使用,它调用了反三角函数ArcSin和ArcCos及Log函数,打印了三个函数的函数表。
§2.8.3 源程序清单
程序1：MATH.PAS
{***************************************}
{ UNIT : MATH }
{ Mathematics functions unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{***************************************}
Unit Math;
(*
{$D-,S-}
*)
Interface
function Sign(x : real) : integer;
function Power(x,y : real) : real;
function Log(x,y : real) : real;
function Amax(mxn1, mxn2 : real) : real; { FORTRAN 77 function }
function Amin(mxn1, mxn2 : real) : real; { FORTRAN 77 function }
function Max(mxn1, mxn2 : longint) : longint; { FORTRAN 77 function }
function Min(mxn1, mxn2 : longint) : longint; { FORTRAN 77 function }
function Tan(x : real) : real;
function CTan(x : real) : real;
function ArcSin(x : real) : real;
function ArcCos(x : real) : real;
function Comb(n,m : word) : longint;
function Permut(n,m : word) : longint;
function Factor(n : word) : longint;
implementation
function Sign;
{ get the sign of a real }
begin
if x >= 0 then sign := 1 else sign := -1;
end;
function Tan(x : real) : real;
begin
Tan := Sin(x) / Cos(x);
end;
function CTan(x : real) : real;
begin
CTan := Cos(x) / Sin(x);
end;
function ArcSin(x:Real):Real;
{ ArcSin(x)= ArcTan(x/1-x) }
var o : real;
begin
o := abs(x);
if o > 1.0 then writeln('Illegal arguement');
if o = 1.0 then
if x < 0.0 then ArcSin := -0.5 * pi
else ArcSin := 0.5 * pi
else ArcSin := ArcTan(x/sqrt(1.0 - x*x));
end;
function ArcCos(x:Real):Real;
begin
ArcCos := (0.5 * pi) - ArcSin(x)
end;
function Amax(Mxn1,Mxn2:real):real;
begin
Amax := Mxn1;
if Mxn2>Mxn1 then Amax := Mxn2;
end;
function Amin(Mxn1,Mxn2:real):real;
begin
Amin := Mxn1;
if Mxn2end;
function Max;
begin
Max := Mxn1;
if Mxn2>Mxn1 then Max := Mxn2;
end;
function Min;
begin
Min := Mxn1;
if Mxn2end;
function Log(x,y:real):real;
begin
Log := ln(y)/ln(x);
end;
function poweri(x:real; n:integer):real;
function rlscan(x:real; n:integer):real;
var
y, z : real;
o : boolean;
bign : integer;
begin
bign := n;
y := 1.0;
z := x;
while bign > 0 do
begin
o := odd(bign);
bign := bign div 2;
if o then
begin
y := y * z;
rlscan := y;
end;
z := z * z;
end;
end; (* func rlscan *)
begin
if n > 0 then
poweri := rlscan(x,n)
else
if (x <> 0.0) and (n < 0) then
begin
n := -n;
poweri := 1.0 / rlscan(x,n);
end
else
if (n = 0) and (x <> 0) then
poweri := 1.0
else
if (n = 0) and (x = 0) then
begin
writeln('0 to the 0 power.');
poweri := 0.0;
end
else
if (n < 0) and (x = 0) then
begin
writeln('Division by zero.');
poweri := 0.0;
end;
end; (* function poweri *)
function power(x,y:real):real;
begin
if (y = int(y)) and (abs(y) <= 32767) then
power := poweri(x,trunc(y))
else
if x > 0 then
power := exp(y*ln(x))
else
if x < 0 then begin
writeln('X < 0.');
power := 0.0;
end
else
if (x=0) and (y=0) then begin
writeln('0 to the 0 power.');
power := 0.0;
end
else
if (x=0) and (y<0) then begin
writeln('0 to a negative power.');
power := 0.0;
end
else
power := 0.0;
end; { end of function power }
function factor;
{ This is a subroutine to calculte the factorial }
{ of a integer number. }
var i : integer;
x1 : longint;
begin
x1 := 1;
for i := 1 to n do x1 := x1 * i;
factor := x1;
end;
function permut;
{ This is a subroutine to calculte the permutation }
{ of two integer number. }
var x1 : longint;
i : integer;
begin
x1 := 1;
for i := 1 to m do x1 := x1*(n-i+1);
permut := x1;
end;
function comb;
{ This is a subroutine to calculte the combination }
{ of two integer number. }
var x1,x2,x3,i : longint;
begin
x3 := 1;
if (m > (n-m)) then
begin
x1 := m;
x2 := n-m;
end
else
begin
x1 := n-m;
x2 := m;
end;
for i := 1 to x2 do x3 := x3*(n-i+1);
x1 := factor(x2);
comb := x3 div x1;
end;
end.
程序2:MATHDEMO.PAS
{-----------------------------------}
{ MATHDEMO.PAS }
{ Demonstrates the usage of MATH }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
{$F+}
program Mathdemo;
uses astr,math;
type
func = function(a:real):real; { decleare function type }
procedure PrintArcTriangleTable(proc1:func);
var
i,j : integer;
begin
i := 0;
repeat
for j := 1 to 5 do
begin
inc(i);
write(RealToStr(i/100,5,2),'|');
write(RealToStr(proc1(i/100)/pi*180,6,3),space(2));
end;
writeln;
until i = 100;
end;
procedure PrintLog;
var
i,j : integer;
begin
i := 0;
repeat
for j := 1 to 5 do
begin
inc(i);
write(WordToStr(i,4),'|');
write(RealToStr(log(10,i),6,4),space(2));
end;
writeln;
until i = 1000;
end;
begin
WriteLn('ArcSin Table x|degree');
PrintArcTriangleTable(ArcSin);
Writeln;
WriteLn('Arccos Table x|degree');
printArcTriangleTable(ArcCos);
Writeln;
Writeln('Log10(x) Table x|log10(x)');
PrintLog;
end.
§2.9 矩阵运算单元MATRIX
MATRIX单元含12个过程和函数，处理矩阵的加、减、乘、求逆、转置等运算，为TURBO PASCAL扩展了矩阵运算功能。
MATRIX中定义了矩阵最大元素个数常量MaxNumMatElement，同时定义了3个与矩阵有关的新类型，即矩阵元素类型MatElementType、最大矩阵类型MaxMatType和最大矩阵指针类型MaxMatPtr。
§2.9.1 MATRIX的函数和过程
1.MatMaxElement函数
功 能 求矩阵最大元素
用 法 MatMaxElement(mata:pointer;n,m:integer)
结果类型 实型
说 明 mata为指定的矩阵，无类型指针变量
n为矩阵mata的行数
m为矩阵mata的列数
返 回 值 矩阵的最大元素
2.MatZero过程
功 能 构造全零矩阵
用 法 MatZero(mata : pointer ; n,m : integer)
说 明 参数意义同MatMaxElement
3.MatCon过程
功 能 构造常数矩阵
用 法 MatCon(mata : pointer ; n,m : integer)
说 明 参数意义同MatMaxElement
4.MatIdn过程
功 能 构造单位矩阵
用 法 MatIdn(mata : pointer ; n : integer)
说 明 mata为指定的方阵，无类型指针变量
n为方阵mata的阶数
5.MatEqual过程
功 能 矩阵相等运算
用 法 MatEqual(mata,matb : pointer; n,m : integer)
说 明 mata，matb为指定的矩阵，无类型指针变量
n为矩阵的行数
m为矩阵的列数
6.MatAdd过程
功 能 矩阵相加运算
用 法 MatAdd(mata,matb,matc : pointer; n,m : integer)
说 明 mata，matb为指定的矩阵，无类型指针变量
matc为mata和matb相加的结果矩阵，无类型指针变量
n为矩阵的行数
m为矩阵的列数
7.MatSub过程
功 能 矩阵相减运算
用 法 MatSub(mata,matb,matc : pointer; n,m : integer)
说 明 mata，matb为指定的矩阵，无类型指针变量
matc为mata和matb相减的结果矩阵，无类型指针变量
n为矩阵的行数
m为矩阵的列数
8.MatMulConst过程
功 能 常数与矩阵相乘运算
用 法 MatMulConst(mata : pointer; c : real; n, m : integer)
说 明 mata为指定的矩阵，无类型指针变量
c为指定的常数
n为矩阵的行数
m为矩阵的列数
9.MatMul过程
功 能 矩阵相乘运算
用 法 MatMul(mata,matb,matc : pointer; n,m,o : integer)
说 明 mata，matb为指定的矩阵，无类型指针变量
matc为mata和matb相乘的结果矩阵，无类型指针变量
n为矩阵mata的行数
m为矩阵mata的列数，矩阵matb的行数
o为矩阵matb的列数
10.MatTran过程
功 能 矩阵转置运算
用 法 MatTran(mata,matb : pointer; n,m : integer)
说 明 mata为指定的矩阵,无类型指针变量
matb为转置矩阵，无类型指针变量
n为矩阵mata的行数
m为矩阵mata的列数
11.MatInv过程
功 能 求逆矩阵运算
用 法 MatInv(mata,matb : pointer; n : integer)
说 明 mata为指定的方阵，无类型指针变量
matb为逆矩阵，无类型指针变量
n为矩阵mata的阶数
12.DetEval函数
功 能 求指定方阵对应行列式的值
用 法 DetEval(mata : pointer; n : integer)
结果类型 实型
说 明 mata为指定的方阵，无类型指针变量
n为方阵mata的阶数
返 回 值 行列式的值
§2.9.2 MATRIX的使用
MATRDEMO.PAS演示了MATRIX单元部分过程的使用。该程序中用MATRIX单元提供的过程构造了一个通用的求解线性方程组的过程LinEquSol,读者可以仿此过程构造自己的程序。
§2.9.3 源程序清单
程序1:MATRIX.PAS
{***********************************}
{ UNIT : MATRIX }
{ Matrix procedure unit }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{***********************************}
unit matrix;
{ This unit includes 12 subroutines on Matrix. You }
{ can use it to do your work. }
interface
const
MaxNumMatElement = 10000;
type
MatElementType = real;
MaxMatType = array[1..MaxNumMatElement] of MatElementType;
MaxMatPtr = ^MaxMatType;
function MatMaxElement(mata:pointer;n,m:integer):real;
procedure MatZero(mata : pointer ; n,m : integer);
procedure MatCon(mata : pointer ; n,m : integer);
procedure MatIdn(mata : pointer ; n : integer);
procedure MatEqual(mata,matb : pointer; n,m : integer);
procedure MatAdd(mata,matb,matc : pointer; n,m : integer);
procedure MatSub(mata,matb,matc : pointer; n,m : integer);
procedure MatMulConst(mata : pointer; c : real; n, m : integer);
procedure MatMul(mata,matb,matc : pointer; n,m,o : integer);
procedure MatTran(mata,matb : pointer; n,m : integer);
procedure MatInv(mata,matb : pointer; n : integer);
function DetEval(mata : pointer; n : integer):real;
implementation
function MatMaxElement;
var p1 : MaxMatPtr;
i,j : integer;
max : real;
begin
p1 := mata;
max := 0;
for i := 1 to n do
for j := 1 to m do
if abs(p1^[(i-1) *m + j]) > max
then max := abs(p1^[(i-1) *m + j]);
MatMaxElement := max;
end;
procedure MatAdd;
var p1,p2,p3 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
p2 := matb;
p3 := matc;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p3^[l1] := p1^[l1] + p2^[l1];
end;
end;
procedure MatSub;
var p1,p2,p3 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
p2 := matb;
p3 := matc;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p3^[l1] := p1^[l1] - p2^[l1];
end;
end;
procedure MatMul;
var p1,p2,p3 : MaxMatPtr;
i,j,k,l1,l2,l3 : integer;
begin
p1 := mata;
p2 := matb;
p3 := matc;
for i := 1 to n*o do p3^[i] := 0;
for i := 1 to n do
for j := 1 to m do
for k := 1 to o do
begin
l1 := (i-1) * m + j;
l2 := (j-1) * o + k;
l3 := (i-1) * o + k;
p3^[l3] := p3^[l3] + p1^[l1] * p2^[l2];
end;
end;
procedure MatTran;
var p1,p2 : MaxMatPtr;
i,j,l1,l2 : integer;
begin
p1 := mata;
p2 := matb;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
l2 := (j-1) * n + i;
p2^[l2] := p1^[l1];
end;
end;
procedure MatEqual;
var p1,p2 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
p2 := matb;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p2^[l1] := p1^[l1];
end;
end;
procedure MatZero;
var p1 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p1^[l1] := 0;
end;
end;
procedure MatCon;
var p1 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p1^[l1] := 1;
end;
end;
procedure MatIdn;
var p1 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
for i := 1 to n do
for j := 1 to n do
begin
l1 := (i-1) * n + j;
if i = j then p1^[l1] := 1
else p1^[l1] := 0;
end;
end;
procedure MatMulConst;
var p1 : MaxMatPtr;
i,j,l1 : integer;
begin
p1 := mata;
for i := 1 to n do
for j := 1 to m do
begin
l1 := (i-1) * m + j;
p1^[l1] := c * p1^[l1];
end;
end;
procedure MatInv;
var p1,p2 : MaxMatPtr;
i,j,k : integer;
w,s : real;
(****************************************************)
procedure trans(n1,n2:integer);
var i,j : integer;
begin
for i := n1 to n2 do
begin
s := p2^[i] / w;
for j := 1 to k -1 do
p1^[(i - 1) * n + j] := p1^[(i - 1) * n + j]
- s * p1^[(k - 1) * n + j];
if i = k then p1^[(i - 1) * n + k] := 1 - s
else p1^[(i - 1) * n + k] := - s;
end;
end; { **** end trans **** }
(****************** begin MatInv **********************)
begin
matequal(mata,matb,n,n);
p1 := matb;
getmem(p2 , n * n * SizeOf(MatElementType));
for i := 1 to n do
p1^[(i - 1) * n + i] := p1^[(i - 1) * n + i] - 1;
for k := 1 to n do
begin
for i := 1 to n do
begin
if i < k then w := 0
else w := p1^[(i - 1) * n + k];
for j := 1 to k - 1 do
w := w + p1^[(i - 1) * n + j]
* p1^[(j - 1) * n + k];
p2^[i] := w;
end;
w := p2^[k] + 1;
trans(k + 1 , n);
trans(1 , k);
end;
freemem(p2,n * n * SizeOf(MatElementType));
end; { ****** end MatInv ****** }
function DetEval;
var p1,p2 : MaxMatPtr;
i,j,k,l : integer;
p,t,u : real;
label out;
begin
p1 := mata;
getmem(p2,n * n * SizeOf(MatElementType));
for i := 1 to n do
begin
u := 0;
for j := 1 to n do
if abs(p1^[(i-1)*n+j]) > u
then u := abs(p1^[(i-1)*n+j]);
if u < 10e-20 then
begin
deteval := 0;
goto out;
end;
p2^[i] := u;
if u <> 1 then
for j := 1 to n do
p1^[(i-1)*n+j] := p1^[(i-1)*n+j] / u;
end;
p := 1;
for k := 1 to n -1 do
begin
l := k;
t := abs(p1^[(k-1)*n+k]);
for j := k + 1 to n do
if t< abs(p1^[(k-1)*n+j]) then
begin
t := abs(p1^[(k-1)*n+j]);
j := j;
end;
if t < 10e-20 then
begin
deteval := 0;
goto out;
end;
if l <> k then
begin
p := -p;
for i := k to n do
begin
t := p1^[(i-1)*n+k];
p1^[(i-1)*n+k] := p1^[(i-1)*n+l];
p1^[(i-1)*n+l] := t;
end;
end;
p := p * p1^[(k-1)*n+k];
for i := k+1 to n do
begin
t := p1^[(i-1)*n+k] / p1^[(k-1)*n+k];
for j := k + 1 to n do
p1^[(i-1)*n+j] := p1^[(i-1)*n+j]
- p1^[(k-1)*n+j] * t;
end;
end;
t := p * p1^[n*n];
for k := 1 to n do t := t * p2^[k];
deteval := t;
out:
freemem(p2,n * n * SizeOf(MatElementType));
end;
end.
程序2:MATRDEMO.PAS
{-----------------------------------}
{ MATRDEMO.PAS }
{ Demonstrates the usage of MATRIX }
{ Written by Dong Zhanshan }
{ Version : June 1994 }
{-----------------------------------}
Program MatrixDemo;
uses Astr,Matrix;
const
Mn = 3;
Mm = 1;
m1 : array[1..Mn,1..Mn] of MatElementType = ((1,1,1),(1,-1,1),(1,1,-1));
m2 : array[1..Mn,1..Mm] of MatElementType = ((5),(6),(4));
var
m3 : array[1..Mn,1..Mm] of MatElementType;
i,j : integer;
procedure LinEquSol(mata,matb,matc:pointer;n,m:integer);
var
p1,p2,p3,p4 : MaxMatPtr;
begin
p1 := mata;
p2 := matb;
p3 := matc;
getmem(p4,n*n*Sizeof(MatElementType));
MatInv(p1,p4,n);
MatMul(p4,p2,p3,n,n,m);
freemem(p4,n*n*Sizeof(MatElementType));
end;
begin
Writeln('This is a demonstration program for MATRIX unit');
Writeln('Linear Equation:');
for i := 1 to Mn do
begin
for j := 1 to Mn - 1 do
Write('(',RealToStr(m1[i,j],2,0),')',chr(119+j),'+');
inc(j);
Write('(',RealToStr(m1[i,j],2,0),')',chr(119+j),'=');
Writeln(RealToStr(m2[i,1],2,0));
end;
LinEquSol(@m1,@m2,@m3,Mn,Mm);
Writeln('Solution:');
for i := 1 to Mn do
Writeln(Space(5),chr(119+i),'=',RealToStr(m3[i,1],4,1));
writeln;
end.
§2.10 概率分布函数单元PROB
本单元给出了各种常用的概率分布,如F分布、t分布、X攩2攪分布的概率累积函数，使概率统计分析中的统计检验过程变得简单易行，且十分容易自动化。
§2.10.1 PROB单元定义的函数
1.Finv函数
功 能 根据给定的α值和自由度值求对应的F值
用 法 Finv( Alpha, Dfn, Dfe: real )
结果类型 实型
说 明 Alpha为显著性概率,Dfn,Dfe为F分布的自由度
返 回 值 F值
2.SigF函数
功 能 根据给定的自由度和F值计算出其概率值
用 法 SigF( F , Dfn , Dfd : real )
结果类型 实型
说 明 F为欲求其概率值的F值,Dfn和Dfd为F分布的自由度值
返 回 值 概率值
3.tinv函数
功 能 根据给定的α值和自由度值求对应的t值
用 法 tinv( Alpha, Df: real )
结果类型 实型
说 明 Alpha为显著性概率,Df为t分布的自由度
返 回 值 t值
4.Sigt函数
功 能 根据给定的自由度和t值计算出其概率值
用 法 Sigt( t , Df : real )
结果类型 实型
说 明 t为欲求其概率的值,Df为t分布的自由度
返 回 值 概率值
5.SigChi函数
功 能 根据给定的自由度和X攩2攪值计算出其概率值
用 法 SigChi( Chisq , Df : real )
结果类型 实型
说 明 Chisq为欲求其概率的数值,Df为X攩2攪分布的自由度
返 回 值 概率值
§2.10.2 PROB单元的使用
PROBDEMO.PAS演示了PROB单元的Finv函数的使用,它打印df1和df2的自由度均在100以内的F分布的F值表。
§2.10.3 源程序清单
程序1: PROB.PAS
{************************************}
{ UNIT : PROB }
{ Written by Dong Zhanshan }
{ Version : Oct. 1991 }
{************************************}
{$N+,E+}
unit Prob;
interface
uses math;
Function Finv( Alpha, Dfn, Dfe: real ) : real;
Function Sigt( t , Df : real ) : real;
Function tinv( Alpha, Df: real ) : real;
Function SigF( F , Dfn , Dfd : real ) : real;
Function SigChi( Chisq , Df : real ) : real;
implementation
CONST
PI = 3.141592653589793 { Math constant PI };
Xln2sp = 9.18938533204673E-01 { LogE( Sqrt( 2 * PI ) ) };
Rmax = 1.67E+37 { Maximum flt pt number };
Rsmall = 4.19E-37 { Smallest flt pt number };
Rinf = 1.67E+37 { Machine "infinity" };
Zeta = 1.0E-16 { Approx. machine prec. };
MaxPrec = 16 { Max. precision };
Sqrt2 = 1.4142135623730950 { Square root of 2 };
LnTenInv = 0.4342944819032520 { 1 / LN(10) };
LnTwo = 0.6931471805599450 { LN(2) };
Function Erf( Z : real ) : real;
CONST
A: ARRAY[1..14] OF real =
( 1.1283791670955,0.34197505591854,0.86290601455206E-1,
0.12382023274723E-1,0.11986242418302E-2,0.76537302607825E-4,
0.25365482058342E-5,-0.99999707603738,-1.4731794832805,
-1.0573449601594,-0.44078839213875,-0.100684197950781,
-0.12636031836273E-1,-0.1149393366616E-88 );
B: ARRAY[1..12] OF real =
( -0.36359916427762,0.52205830591727E-1,-0.30613035688519E-2,
-0.46856639020338E-4,0.15601995561434E-44,-0.62143556409287E-6,
2.6015349994799,2.9929556755308,1.9684584582884,
0.79250795276064,0.18937020051337,0.22396882835053E-1 );
VAR
U,X,S : real;
begin { Erf }
X := ABS( Z );
IF Z >= 0.0 THEN S := 1.0
ELSE S := -1.0;
IF ( Z = 0.0 ) THEN Erf := 0.0
ELSE IF( X >= 5.5 ) THEN Erf := S
ELSE
begin
U := X * X;
IF( X <= 1.5 ) THEN
Erf := ( X * EXP( -U ) * ( A[1] + U * ( A[2] + U *
( A[3] + U * ( A[4] + U * ( A[5] + U *
( A[6] + U * A[7] ) ) ) ) ) ) / ( 1.0 + U *
( B[1] + U * ( B[2] + U * ( B[3] + U *
( B[4] + U * ( B[5] + U * B[6] ) ) ) ) ) ) ) * S
ELSE
Erf := ( EXP( -U ) * ( A[8] + X * ( A[9] + X *
( A[10] + X * ( A[11] + X * ( A[12] + X *
( A[13] + X * A[14] ) ) ) ) ) ) / ( 1.0 + X *
( B[7] + X * ( B[8] + X * ( B[9] + X *
( B[10] + X * ( B[11] + X * B[12] ) ) ) ) ) ) + 1.0 ) * S;
end;
end { Erf };
Function ALGama( Arg : real ) : real;
CONST
P : ARRAY [ 1 .. 29 ] OF real =
( 4.12084318584770E+00 , 8.56898206283132E+01 , 2.43175243524421E+02 ,
-2.61721858385614E+02 , -9.222613728801552E+02 , -5.17638349802321E+02 ,
-7.74106407133295E+01 , -2.208843997216118E+00 , 5.15505761764082E+00 ,
3.77510679797217E+02 , 5.26898325591498E+03 , 1.95536055406304E+04 ,
1.20431738098716E+04 , -2.06482942053253E+04 , -1.50863022876672E+04 ,
-1.51383183411507E+03 , -1.037701651732998E+04 , -9.82710228142049E+05 ,
-1.97183011586092E+07 , -8.731675438238339E+07 , 1.11938535429986E+08 ,
4.81807710277363E+08 , -2.44832176903288E+08 , -2.40798698017337E+08 ,
8.06588089900001E-04 , -5.94997310888900E-04 , 7.93650067542790E-04 ,
-2.77777777688189E-03 , 8.333333333333300E-02 );
Q : ARRAY [ 1 .. 24 ] OF real =
( 1.00000000000000E+00 , 4.56467718758591E+01 , 3.77837248482394E+02 ,
9.51323597679706E+02 , 8.46075536202078E+02 , 2.62308347026946E+02 ,
2.44351966250631E+01 , 4.09779292109262E-01 , 1.00000000000000E+00 ,
1.28909318901296E+02 , 3.03990304143943E+03 , 2.20295621441566E+04 ,
5.71202553960250E+04 , 5.26228638384119E+04 , 1.44020903717009E+04 ,
6.98327414057351E+02 , 1.00000000000000E+00 , -2.01527519550048E+03 ,
-3.11406284734067E+05 , -1.048577583049994E+07 , -1.11925411626332E+08 ,
-4.04435928291436E+08 , -4.353707148043774E+08 , -7.90261111418763E+07);
VAR
Rarg,Alinc,Scale,Top,Bot,Frac,Algval : real;
I,Iapprox,Iof,Ilo,Ihi : integer;
Qminus,Qdoit : BOOLEAN;
begin { ALGama }
Algval := Rinf;
Scale := 1.0;
Alinc := 0.0;
Frac := 0.0;
Rarg := Arg;
Iof := 1;
Qminus := FALSE;
Qdoit := TRUE;
IF( Rarg < 0.0 ) THEN
begin
Qminus := TRUE;
Rarg := -Rarg;
Top := Int( Rarg );
Bot := 1.0;
IF( ( INT( Top / 2.0 ) * 2.0 ) = 0.0 ) THEN Bot := -1.0;
Top := Rarg - Top;
IF( Top = 0.0 ) THEN
Qdoit := FALSE
ELSE
begin
Frac := Bot * PI / SIN( Top * PI );
Rarg := Rarg + 1.0;
Frac := LN( ABS( Frac ) );
end;
end;
IF( Rarg = 0.0 ) THEN Qdoit := FALSE
ELSE IF( Rarg <= 0.5 ) THEN
begin
Alinc := -LN( Rarg );
Scale := Rarg;
Rarg := Rarg + 1.0;
IF( Scale < Zeta ) THEN
begin
Algval := Alinc;
Qdoit := FALSE;
end;
end
ELSE IF ( Rarg <= 1.5 ) THEN Scale := Rarg - 1.0
ELSE IF( Rarg <= 4.0 ) THEN
begin
Scale := Rarg - 2.0;
Iof := 9;
end
ELSE IF( Rarg <= 12.0 ) THEN Iof := 17
ELSE IF( Rarg <= RMAX ) THEN
begin
Alinc := ( Rarg - 0.5 ) * LN( Rarg ) - Rarg + Xln2sp;
Scale := 1.0 / Rarg;
Rarg := Scale * Scale;
Top := P[ 25 ];
FOR I := 26 TO 29 DO Top := Top * Rarg + P[ I ];
Algval := Scale * Top + Alinc;
Qdoit := FALSE;
end;
IF Qdoit THEN
begin
Ilo := Iof + 1;
Ihi := Iof + 7;
Top := P[ Iof ];
Bot := Q[ Iof ];
FOR I := Ilo TO Ihi DO
begin
Top := Top * Rarg + P[ I ];
Bot := Bot * Rarg + Q[ I ];
end;
Algval := Scale * ( Top / Bot ) + Alinc;
end;
IF( Qminus ) THEN Algval := Frac - Algval;
ALGama := Algval;
end { ALGama };
Function CDBeta( X, Alpha, Beta: real; Dprec, MaxIter : integer;
VAR Cprec : real; VAR Iter, Ifault : integer ) : real;
VAR
Epsz,A,B,C,F,Fx,Apb,Zm,Alo,Ahi,Blo,Bhi,Bod,Bev,Zm1,D1,Aev,Aod : real;
Ntries : integer;
Qswap,Qdoit,Qconv : BOOLEAN;
LABEL 20, 9000;
begin { CdBeta }
IF Dprec > MaxPrec THEN Dprec := MaxPrec
ELSE IF Dprec <= 0 THEN Dprec := 1;
Cprec := Dprec;
Epsz := Power(10, -Dprec );
X := X;
A := Alpha;
B := Beta;
QSwap := FALSE;
CDBeta := -1.0;
Qdoit := TRUE;
Ifault := 1;
IF( X <= 0.0 ) THEN GOTO 9000;
IF( ( A <= 0.0 ) OR ( B <= 0.0 ) ) THEN GOTO 9000;
CDBeta := 1.0;
Ifault := 0;
IF( X >= 1.0 ) THEN GOTO 9000;
IF( X > ( A / ( A + B ) ) ) THEN
begin
X := 1.0 - X;
A := Beta;
B := Alpha;
QSwap := TRUE;
end;
IF( ( X = A ) OR ( X = B ) ) THEN GOTO 20;
IF( A = ( ( B * X ) / ( 1.0 - X ) ) ) THEN GOTO 20;
IF( ABS( A - ( X * ( A + B ) ) ) <= Epsz ) THEN GOTO 20;
C := ALGama( A + B ) + A * LN( X ) +
B * LN( 1.0 - X ) - ALGama( A ) - ALGama( B ) -
LN( A - X * ( A + B ) );
IF( ( C < -36.0 ) AND QSwap ) THEN GOTO 9000;
CDBeta := 0.0;
IF( C < -180.0 ) THEN GOTO 9000;
20:
Apb := A + B;
Zm := 0.0;
Alo := 0.0;
Bod := 1.0;
Bev := 1.0;
Bhi := 1.0;
Blo := 1.0;
Ahi := EXP( ALGama( Apb ) + A * LN( X ) +
B * LN( 1.0 - X ) - ALGama( A + 1.0 ) -
ALGama( B ) );
F := Ahi;
Iter := 0;
Qconv := FALSE;
REPEAT
Fx := F;
Zm1 := Zm;
Zm := Zm + 1.0;
D1 := A + Zm + Zm1;
Aev := -( A + Zm1 ) * ( Apb + Zm1 ) * X / D1 / ( D1 - 1.0 );
Aod := Zm * ( B - Zm ) * X / D1 / ( D1 + 1.0 );
Alo := Bev * Ahi + Aev * Alo;
Blo := Bev * Bhi + Aev * Blo;
Ahi := Bod * Alo + Aod * Ahi;
Bhi := Bod * Blo + Aod * Bhi;
IF ABS( Bhi ) < Rsmall THEN Bhi := 0.0;
IF( Bhi <> 0.0 ) THEN
begin
F := Ahi / Bhi;
Qconv := ( ABS( ( F - Fx ) / F ) < Epsz );
end;
inc(Iter);
UNTIL ( ( Iter > MaxIter ) OR Qconv ) ;
IF ( Qswap ) THEN CDBeta := 1.0 - F
ELSE CDBeta := F;
IF ABS( F - Fx ) <> 0.0 THEN Cprec := -log(10, ABS( F - Fx ) )
ELSE Cprec := MaxPrec;
9000: { Error exit }
end; { CDBeta }
Function Ninv( P : real ) : real;
const
Lim = 1.0E-20;
PN : ARRAY[1..5] OF real =
( -0.322232431088 , -1.0 , -0.342242088547 ,
-0.0204231210245 , -0.453642210148E-4 );;
QN : ARRAY[1..5] OF real =
( 0.0993484626060 , 0.588581570495 , 0.531103462366 ,
0.103537752850 , 0.38560700634E-2 );
VAR
Y,Pr,Nv: real;
begin { Ninv }
Ninv := 0.0;
IF( P > 0.5 ) THEN Pr := 1.0 - P
ELSE Pr := P;
IF( ( Pr >= Lim ) AND ( Pr <> 0.5 ) ) THEN
begin
Y := SQRT ( LN( 1.0 / Pr / Pr ) );
Nv := Y + ((((Y * PN[ 5 ] + PN[ 4 ]) * Y + PN[ 3 ] ) * Y
+ PN[ 2 ]) * Y + PN[ 1 ] ) /
((((Y * QN[ 5 ] + QN[ 4 ]) * Y + QN[ 3 ] ) * Y
+ QN[ 2 ]) * Y + QN[ 1 ] );
IF( P < 0.5 ) THEN Ninv := -Nv
ELSE Ninv := Nv;
end;
end; { Ninv }
Function BetaInv( P, Alpha, Beta : real; MaxIter,Dprec :integer;
VAR Iter : integer; VAR Cprec : real;
VAR Ierr : integer ) : real;
VAR
Eps,Xim1,Xi,Xip1,Fim1,Fi,W,Cmplbt,Adj,Sq,R,
S,T,G,A,B,PP,H,A1,B1,Eprec : real;
Done : BOOLEAN;
Jter : integer;
LABEL 10, 30, 9000;
begin { BetaInv }
Ierr := 1;
BetaInv := P;
IF( ( Alpha <= 0.0 ) OR ( Beta <= 0.0 ) ) THEN GOTO 9000;
IF( ( P > 1.0 ) OR ( P < 0.0 ) ) THEN GOTO 9000;
IF( ( P = 0.0 ) OR ( P = 1.0 ) ) THEN
begin
Iter := 0;
Cprec := MaxPrec;
GOTO 9000;
end;
IF Dprec > MaxPrec THEN Dprec := MaxPrec
ELSE IF Dprec <= 0 THEN Dprec := 1;
Cprec := Dprec;
Eps := power(10, -2 * Dprec );
IF( P > 0.5 ) THEN
begin
A := Beta;
B := Alpha;
PP := 1.0 - P;
end
ELSE
begin
A := Alpha;
B := Beta;
PP := P;
end;
Ierr := 0;
Cmplbt := ALGama( A ) + ALGama( B ) - ALGama( A + B );
Fi := Ninv( 1.0 - PP );
IF( ( A > 1.0 ) AND ( B > 1.0 ) ) THEN
begin
R := ( Fi * Fi - 3.0 ) / 6.0;
S := 1.0 / ( A + A - 1.0 );
T := 1.0 / ( B + B - 1.0 );
H := 2.0 / ( S + T );
W := Fi * SQRT( H + R ) / H - ( T - S ) *
( R + 5.0 / 6.0 - 2.0 / ( 3.0 * H ) );
Xi := A / ( A + B * EXP( W + W ) );
end
ELSE
begin
R := B + B;
T := 1.0 / ( 9.0 * B );
T := R * Power( ( 1.0 - T + Fi * SQRT( T ) ) , 3 );
IF( T <= 0.0 ) THEN
Xi := 1.0 - EXP( ( LN( ( 1.0 - PP ) * B ) + Cmplbt ) / B )
ELSE
begin
T := ( 4.0 * A + R - 2.0 ) / T;
IF( T <= 1.0 ) THEN
Xi := EXP( (LN( PP * A ) + Cmplbt) / PP )
ELSE
Xi := 1.0 - 2.0 / ( T + 1.0 );
end;
end;
IF ( Xi < 0.0001 ) THEN Xi := 0.0001;
IF ( Xi > 0.9999 ) THEN Xi := 0.9999;
A1 := 1.0 - A;
B1 := 1.0 - B;
Fim1 := 0.0;
Sq := 1.0;
Xim1 := 1.0;
Iter := 0;
Done := FALSE;
REPEAT
Iter := Iter + 1;
Done := Done OR ( Iter > MaxIter );
Fi := CDBeta( Xi, A, B, Dprec+1, MaxIter, Eprec, Jter, Ierr );
IF( Ierr <> 0 ) THEN
begin
Ierr := 2;
Done := TRUE;
end
ELSE
begin
Fi := ( Fi - PP ) * EXP( Cmplbt + A1 * LN( Xi ) +
B1 * LN( 1.0 - Xi ) );
IF( ( Fi * Fim1 ) <= 0.0 ) THEN Xim1 := Sq;
G := 1.0;
10: REPEAT
Adj := G * Fi;
Sq := Adj * Adj;
IF( Sq >= Xim1 ) THEN G := G / 3.0;
UNTIL( Sq < Xim1 );
Xip1 := Xi - Adj;
IF( ( Xip1 < 0.0 ) OR ( Xip1 > 1.0 ) ) THEN
begin
G := G / 3.0;
GOTO 10;
end;
IF( Xim1 <= Eps ) THEN GOTO 30;
IF( Fi * Fi <= Eps ) THEN GOTO 30;
IF( ( Xip1 = 0.0 ) OR ( Xip1 = 1.0 ) ) THEN
begin
G := G / 3.0;
GOTO 10;
end;
IF( Xip1 <> Xi ) THEN
begin
Xi := Xip1;
Fim1 := Fi;
end
ELSE
Done := TRUE;
end;
UNTIL( Done );
30:
BetaInv := Xi;
IF( P > 0.5 ) THEN BetaInv := 1.0 - Xi;
IF ABS( Xi - Xim1 ) <> 0.0 THEN
Cprec := -Log(10,ABS( Xi - Xim1 ) )
ELSE
Cprec := MaxPrec;
9000:
IF Ierr <> 0 THEN BetaInv := -1.0;
end; { BetaInv }
Function Finv( Alpha, Dfn, Dfe: real ) : real;
CONST
MaxIter = 100;
Dprec = 10;
VAR
Fin,Cprec : real;
Iter,Ierr : integer;
begin { Finv }
Fin := -1.0;
IF( ( Dfn > 0.0 ) AND ( Dfe > 0.0 ) ) THEN
IF( ( Alpha >= 0.0 ) AND ( Alpha <= 1.0 ) ) THEN
begin
Fin := BetaInv( 1.0 - Alpha, Dfn/2.0, Dfe/2.0, MaxIter, Dprec,
Iter, Cprec, Ierr );
IF( ( Fin >= 0.0 ) AND ( Fin < 1.0 ) AND ( Ierr = 0 ) ) THEN
Fin := Fin * Dfe / ( Dfn * ( 1.0 - Fin ) );
end;
Finv := Fin;
end; { Finv }
Function Sigt( t , Df : real ) : real;
CONST
Dprec = 12;
MaxIter = 200;
VAR
Iter,Ifault : integer;
Pval, Cprec : real;
begin { Sigt }
Pval := -1.0;
IF( Df > 0.0 ) THEN
begin
Pval := CDBeta( Df / ( Df + t * t ), Df / 2.0, 0.5,
Dprec, MaxIter, Cprec, Iter, Ifault );
IF Ifault <> 0 THEN Pval := -1.0;
end;
Sigt := Pval;
end { Sigt };
Function tinv( Alpha, Df: real ) : real;
CONST
MaxIter = 100;
Dprec = 10;
VAR
tin,Cprec : real;
Iter,Ierr : integer;
begin { tinv }
Alpha := 1 - Alpha;
tin := -1.0;
IF( Df > 0.0 ) THEN
IF( ( Alpha >= 0.0 ) AND ( Alpha <= 1.0 ) ) THEN
begin
tin := BetaInv( Alpha, 0.5, Df / 2.0, MaxIter, Dprec,
Iter, Cprec, Ierr );
IF( ( tin >= 0.0 ) AND ( tin < 1.0 ) AND ( Ierr = 0 ) ) THEN
tin := SQRT( tin * Df / ( 1.0 - tin ) );
end;
tinv := tin;
end { tinv };
Function GammaIn( Y, P : real; Dprec, MaxIter : integer;
VAR Cprec : real; VAR Iter : integer;
VAR Ifault : integer ) : real;
CONST
Oflo = 1.0E+37;
MinExp = -87.0;
VAR
F,C,A,B,Term,Gin,An,Rn,Dif,Eps : real;
Pn : ARRAY[1..6] OF real;
Done : BOOLEAN;
LABEL 9000;
begin { GammaIn }
Ifault := 1;
GammaIn := 1.0;
IF( ( Y <= 0.0 ) OR ( P <= 0.0 ) ) THEN GOTO 9000;
Ifault := 0;
F := P * LN( Y ) - ALGama( P + 1.0 ) - Y;
IF ( F < MinExp ) THEN GOTO 9000;
F := EXP( F );
IF( F = 0.0 ) THEN GOTO 9000;
IF Dprec > MaxPrec THEN Dprec := MaxPrec
ELSE IF Dprec <= 0 THEN Dprec := 1;
Cprec := Dprec;
Eps := power(10, -Dprec );
IF( ( Y > 1.0 ) AND ( Y >= P ) ) THEN
begin { Continued Fraction }
A := 1.0 - P;
B := A + Y + 1.0;
Term := 0.0;
Pn[ 1 ] := 1.0;
Pn[ 2 ] := Y;
Pn[ 3 ] := Y + 1.0;
Pn[ 4 ] := Y * B;
Gin := Pn[ 3 ] / Pn[ 4 ];
Done := FALSE;
Iter := 0;
REPEAT
Iter := Iter + 1;
A := A + 1.0;
B := B + 2.0;
Term := Term + 1.0;
An := A * Term;
Pn[ 5 ] := B * Pn[ 3 ] - An * Pn[ 1 ];
Pn[ 6 ] := B * Pn[ 4 ] - An * Pn[ 2 ];
IF( Pn[ 6 ] <> 0.0 ) THEN
begin
Rn := Pn[ 5 ] / Pn[ 6 ];
Dif := ABS( Gin - Rn );
IF( Dif <= Eps ) THEN
IF( Dif <= ( Eps * Rn ) ) THEN Done := TRUE;
Gin := Rn;
end;
Pn[ 1 ] := Pn[ 3 ];
Pn[ 2 ] := Pn[ 4 ];
Pn[ 3 ] := Pn[ 5 ];
Pn[ 4 ] := Pn[ 6 ];
IF( ABS( Pn[ 5 ] ) >= Oflo ) THEN
begin
Pn[ 1 ] := Pn[ 1 ] / Oflo;
Pn[ 2 ] := Pn[ 2 ] / Oflo;
Pn[ 3 ] := Pn[ 3 ] / Oflo;
Pn[ 4 ] := Pn[ 4 ] / Oflo;
end;
UNTIL ( Iter > MaxIter ) OR Done;
Gin := 1.0 - ( F * Gin * P );
GammaIn := Gin;
IF Dif <> 0.0 THEN Cprec := -Log(10,Dif )
ELSE Cprec := MaxPrec;
end
ELSE
begin { Infinite series }
Iter := 0;
Term := 1.0;
C := 1.0;
A := P;
Done := FALSE;
REPEAT
A := A + 1.0;
Term := Term * Y / A;
C := C + Term;
Iter := Iter + 1;
UNTIL ( Iter > MaxIter ) OR ( ( Term / C ) <= Eps );
GammaIn := C * F;
Cprec := -Log(10,Term / C );
end;
9000: { Error exit }
end; { GammaIn }
Function SigChi( Chisq , Df : real ) : real;
CONST
MaxIter = 200;
Dprec = 12;
VAR
Ierr,Iter : integer;
Cprec: real;
begin { SigChi }
SigChi := 1.0 - GammaIn( Chisq / 2.0, Df / 2.0, Dprec, MaxIter,
Cprec, Iter, Ierr );
IF ( Ierr <> 0 ) THEN SigChi := -1.0;
end; { SigChi }
Function Cinv( P, V: real; VAR Ifault: integer ) : real;
CONST
E = 1.0E-8;
Dprec = 8;
MaxIter = 100;
VAR
XX,C,Ch,Q,P1,P2,T,X,B,A,G,S1,S2,S3,S4,S5,S6,Cprec : real;
Iter : integer;
LABEL 9000;
begin { Cinv }
Cinv := -1.0;
Ifault := 1;
IF ( P < E ) OR ( P > ( 1.0 - E ) ) THEN GOTO 9000;
Ifault := 2;
IF( V <= 0.0 ) THEN GOTO 9000;
P := 1.0 - P;
XX := V / 2.0;
G := ALGama( XX );
Ifault := 0;
C := XX - 1.0;
IF( V < ( -1.24 * LN( P ) ) ) THEN
begin
Ch := Power( P * XX * EXP( G + XX * LnTwo ) , ( 1.0 / XX ) );
IF Ch < E THEN
begin
Cinv := Ch;
GOTO 9000;
end;
end
ELSE
IF ( V <= 0.32 ) THEN
begin
Ch := 0.4;
A := LN( 1.0 - P );
REPEAT
Q := Ch;
P1 := 1.0 + Ch * ( 4.67 + Ch );
P2 := Ch * ( 6.73 + Ch * ( 6.66 + Ch ) );
T := -0.5 + ( 4.67 + 2.0 * Ch ) / P1 -
( 6.73 + Ch * ( 13.32 + 3.0 * Ch ) ) / P2;
Ch := Ch - ( 1.0 - EXP( A + G + 0.5 * Ch + C * LnTwo ) *
P2 / P1 ) / T;
UNTIL( ABS( Q / Ch - 1.0 ) <= 0.01 );
end
ELSE
begin
X := Ninv( P );
P1 := 2.0 / ( 9.0 * V );
Ch := V * power( ( X * SQRT( P1 ) + 1.0 - P1 ) , 3 );
IF ( Ch > ( 2.2 * V + 6.0 ) ) THEN
Ch := -2.0 * ( LN( 1.0 - P ) - C * LN( 0.5 * Ch ) + G );
end;
REPEAT
Q := Ch;
P1 := 0.5 * Ch;
P2 := P - GammaIn( P1, XX, Dprec, MaxIter, Cprec, Iter, Ifault );
IF( Ifault <> 0 ) OR ( Iter > MaxIter ) THEN
Ifault := 3
ELSE
begin
T := P2 * EXP( XX * LnTwo + G + P1 - C * LN( Ch ) );
B := T / Ch;
A := 0.5 * T - B * C;
S1 := ( 210.0 + A * ( 140.0 + A * ( 105.0 + A * ( 84.0 + A *
( 70.0 + 60.0 * A ) ) ) ) ) / 420.0;
S2 := ( 420.0 + A * ( 735.0 + A * ( 966.0 + A * ( 1141.0 +
1278.0 * A ) ) ) ) / 2520.0;
S3 := ( 210.0 + A * ( 462.0 + A * ( 707.0 + 932.0 * A ) ) )
/ 2520.0;
S4 := ( 252.0 + A * ( 672.0 + 1182.0 * A ) + C * ( 294.0 + A *
( 889.0 + 1740.0 * A ) ) ) / 5040.0;
S5 := ( 84.0 + 264.0 * A + C * ( 175.0 + 606.0 * A ) ) / 2520.0;
S6 := ( 120.0 + C * ( 346.0 + 127.0 * C ) ) / 5040.0;
Ch := Ch + T * ( 1.0 + 0.5 * T * S1 - B * C * ( S1 - B *
( S2 - B * ( S3 - B * ( S4 - B * ( S5 - B * S6 ) ) ) ) ) );
end;
UNTIL ( ABS( ( Q / Ch ) - 1.0 ) <= E ) OR ( Ifault <> 0 );
IF Ifault = 0 THEN Cinv := Ch
ELSE Cinv := -1.0;
9000: ;
end; { Cinv }
Function SigF( F , Dfn , Dfd : real ) : real;
CONST
Dprec = 12;
MaxIter = 200;
VAR
Iter,Ifault : integer;
Pval,Cprec : real;
begin { SigF }
Pval := -1.0;
IF ( Dfn > 0.0 ) AND ( Dfd > 0.0 ) THEN
begin
Pval := CDBeta( Dfd / ( Dfd + F * Dfn ), Dfd / 2.0, Dfn / 2.0,
Dprec, MaxIter, Cprec, Iter, Ifault );
IF Ifault <> 0 THEN Pval := -1.0;
end;
SigF := Pval;
end { SigF };
Function CDNorm( X : real ) : real;
begin { CDNorm }
IF X >= 0.0 THEN CDNorm := ( 1.0 + Erf( X / Sqrt2 ) ) / 2.0
ELSE CDNorm := ( 1.0 - Erf( -X / Sqrt2 ) ) / 2.0;
end; { CDNorm }
Function SigNorm( X : real ) : real;
begin { SigNorm }
IF X >= 0.0 THEN SigNorm := 1.0 - ( 1.0 + Erf( X / Sqrt2 ) ) / 2.0
ELSE SigNorm := 1.0 - ( 1.0 - Erf( -X / Sqrt2 ) ) / 2.0;
end; { SigNorm }
Function Ninv2( P : real ) : real;
VAR
Xp,P1,Z,X3,X2,X1,Phi : real;
begin { Ninv2 }
Xp := Ninv( P );
P1 := SigNorm( Xp );
Phi := SQRT( 1.0 / ( 2.0 * PI ) ) * EXP( -( Xp * Xp ) / 2.0 );
Z := ( P - P1 ) / Phi;
X3 := ( 2.0 * ( Xp * Xp ) + 1.0 ) * Z / 3.0;
X2 := ( X3 + Xp ) * Z / 2.0;
X1 := ( ( X2 + 1.0 ) * Z );
Ninv2 := Xp + X1;
end; { Ninv2 }
end.
程序2: PROBDEMO.PAS
{-----------------------------------}
{ PROBDEMO.PAS }
{ Demonstrates the usage of PROB }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{-----------------------------------}
{$N+,E+}
program ProbDemo;
uses Prob;
var i,j,k : integer;
x,y,z : real;
begin
k := 0;
for i := 1 to 100 do
for j := 1 to 100 do
begin
inc(k);
write(Finv(0.05,i,j):9:3,'[',i:3,',',j:3,']');
if k = 4 then
begin
k := 0;
writeln;
end;
end;
end.
§2.11 复数运算单元COMPLEX
§2.11.1 概述
在一般的PASCAL教科书中，按如下方式定义复数类型和复数运算:
Type complex = record
real_part : real;
image_part : real;
end;
procedure CAdd(x,y:complex ; var result : complex);
procedure CSub(x,y:complex ; var result : complex);
procedure CMul(x,y:complex ; var result : complex);
procedure CDiv(x,y:complex ; var result : complex);
即把复数设计为具有实部和虚部的记录类型，其运算均采用过程来完成，而不是用函数来完成，这是由于PASCAL语言本身限制的。在PASCAL语言中，一个函数的返回类型只能是基本数据类型，而不能是复合数据类型。利用上述复数运算过程，一个缺点是运算表达不明确，二是中间的辅助变量较多。
下面介绍一种使用absolute和字符串类型编写的复数运算函数的方法。
TURBO PASCAL的absolute保留字，使一个变量与某个已定义的变量共享同一内存区域，这样对同一内存单元可以采用不同的方式进行存取。
为应用absolute子句，定义下列类型:
type
complexr = record
len : byte;
rp : real;
ip : real;
end;
complexs = string[sizeof(real)*2];
这样就可以用absolute将complexr和complexs对应起来，内部运算用complexr类型，外部传递参数和函数值的返回用complexs类型。复数的运算可定义为:
function CAdd(x,y:complexr):complexs;
function CSub(x,y:complexr):complexs;
function CMul(x,y:complexr):complexs;
function CDiv(x,y:complexr):complexs;
这种定义克服了第一种定义的缺点。
§2.11.2 COMPLEX的过程和函数
该单元定义了两种新的数据类型，即complexr和complexs，complexs是COMPLEX单元的公用数据类型,complexr是COMPLEX单元的私有数据类型,还定义了5个函数和1个过程。两种新的数据类型已在上面讲过,下面介绍其过程和函数。
1.CAdd函数
功 能 执行复数加法运算
用 法 CAdd(x,y:complexr)
结果类型 complexs
说 明 x,y为complexr类型的值参
返 回 值 complexs类型的值
2.CSub函数
功 能 执行复数减法运算
用 法 CSub(x,y:complexr)
结果类型 complexs
说 明 x,y为complexr类型的值参
返 回 值 complexs类型的值
3.CMul函数
功 能 执行复数乘法运算
用 法 CMul(x,y:complexr)
结果类型 complexs
说 明 x,y为complexr类型的值参
返 回 值 complexs类型的值
4.CDiv函数
功 能 执行复数除法运算
用 法 CDiv(x,y:complexr)
结果类型 complexs
说 明 x,y为complexr类型的参数
返 回 值 complexs类型的值
5.Cplx函数
功 能 构造一个新的复数
用 法 Cplx(x,y:real)
结果类型 complexs
说 明 x,y为实型值参
返 回 值: complexs类型的值
6.OCplx过程
功 能 输出一个复数
用 法 OCplx(s: string; x: complexs)
说 明 s为字符串型值参,x为complexs类型的值参
§2.11.3 COMPLEX单元的使用
COMPDEMO.PAS程序演示了COMPLEX单元的使用。首先用CPLX函数构造了4个复数类型，然后输出它们，最后调用COMPLEX单元定义的函数对它们进行加、减、乘、除运算，并输出结果。
§2.11.4 源程序清单
程序1: COMPLEX.PAS
{************************************}
{ UNIT : COMPLEX }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{************************************}
unit Complex;
interface
const
ComplexSize = SizeOf(real) * 2;
Type
Complexs = String[ComplexSize];
function CAdd(x,y : Complexs) : Complexs;
function CSub(x,y : Complexs) : Complexs;
function CMul(x,y : Complexs) : Complexs;
function CDiv(x,y : Complexs) : Complexs;
function Cplx(x,y : real) : Complexs;
procedure OCplx(s : string; x : Complexs);
implementation
Type
Complexr = record
LN : byte; { length }
RP : real; { real part }
IP : real; { image part }
end;
function CAdd;
var
t1 : complexs;
c : complexr absolute x;
d : complexr absolute y;
t2 : complexr absolute t1;
begin
t2.ln := ComplexSize;
t2.RP := c.RP + d.RP;
t2.IP := c.IP + d.IP;
CAdd := t1;
end;
function CSub;
var
t1 : complexs;
c : complexr absolute x;
d : complexr absolute y;
t2 : complexr absolute t1;
begin
t2.ln := ComplexSize;
t2.RP := c.RP - d.RP;
t2.IP := c.IP - d.IP;
CSub := t1;
end;
function CMul;
var
t1 : complexs;
c : complexr absolute x;
d : complexr absolute y;
t2 : complexr absolute t1;
begin
t2.ln := ComplexSize;
t2.RP := c.RP * d.RP - c.IP * d.IP;
t2.IP := c.IP * d.RP + c.RP * d.IP;
CMul := t1;
end;
function CDiv;
var
t1 : complexs;
c : complexr absolute x;
d : complexr absolute y;
t2 : complexr absolute t1;
p : real;
begin
t2.ln := ComplexSize;
p := d.RP * d.RP + d.IP * d.IP;
t2.RP := (c.RP * d.RP + c.IP * d.IP) / p;
t2.IP := (c.IP * d.RP - c.RP * d.IP) / p;
CDiv := t1;
end;
function Cplx;
var
t1 : complexs;
t2 : complexr absolute t1;
begin
t2.ln := ComplexSize;
t2.RP := x;
t2.IP := y;
Cplx := t1;
end;
procedure OCplx;
var
t : complexr absolute x;
begin
Writeln(s:5,' = ',t.RP:10:4,' + ',t.IP:10:4,'i');
end;
end.
程序2: COMPDEMO.PAS
{------------------------------------}
{ COMPDEMO.PAS }
{ Demonstrates the usage of COMPLEX }
{ Written by Dong Zhanshan }
{ Version : Aug. 1994 }
{------------------------------------}
program ComplexDemo;
uses Complex;
var
a,b,c,d : complexs;
begin
a := Cplx(2,5);
b := Cplx(3,4);
c := Cplx(7,5);
d := Cplx(10,6);
OCplx('a',a);
OCplx('b',b);
OCplx('c',c);
OCplx('d',d);
OCplx('a+b',CAdd(a,b));
OCplx('a*c',CMul(a,c));
OCplx('a/b',CDiv(a,b));
OCplx('a-d',CSub(a,d));
end.
- 第二章 实用工具单元
- 第二单元
- 第二单元
- 第二单元
- 第二单元
- 第二单元
- 第二单元作业2.30
- 第二单元作业2.29
- 第二单元作业 2.29
- 第二单元作业 2.30
- 第二单元作业2.29
- 第二单元作业2.30
- 市场营销学第二单元
- 第二单元作业
- Linux学习 第二单元
- 第二册第六单元
- 第二册第七单元
- 第二册第八单元
- 闲谈数据库读写分离
- OpenCV学习笔记（十五）——摄像机的标定和3D重建calib3D
- vim_cheat_sheet_for_programmers
- 技术网站汇总
- dreamweaver随记------dreamweaver中设置超链接不同状态时的样式
- 第二章 实用工具单元
- ArcGIS中的数据集Dataset总结
- 分类信息网的价值体验
- 设计模式C++实现（8）——代理模式
- 重载与重写
- oracle笔记2--基本sql操作
- Echo cancellation
- 能源、生物、信息和新材料将成新经济增长点
- 第三章 实用程序
