Language ---> dBase IV 1.5ã* Author -----> P.A.T. Systemsø C.1993ã* Creation date -> 07/22/1992ã* Last update ---> 01/06/1993ãã* From-> Control Centerã* To---> Noneã* Subs-> Noneãã* This program invokes an External Editor such as Turbo Pascal 6.0'sã* (TP) Desktop Editor by using the PRGAPPLIC setup in the Config.dbã* file. Even though it is only for Entry Programs, with some trickyã* commands we can get it to invoke an External Editor such as TP.ãã* Although I can't do any Compiling or Help Lookup (another use for theã* Manuals), it still is a great and FAST!!!! Editor to work with.ãã* This program will work with any editor that will accept a filenameã* as a parameter.ãã* Example TURBO filename.prg (Turbo Pascal) ORã* WP filename.prg (Word Perfect)ãã* As I am used to TP's Editor, I wished I could use it when I wanted toã* edit a program. Especially a long program that when loaded intoã* dBase's editor is extremely slow, but in TP, editing is FAST!!! Andã* with dBase IV 1.5's NEW Open Architecture, I now have a way to do it.ãã* This program uses the RUN() function to swap out memory to disk soã* that the editor can load in. With the TEDIT command in the Config.dbã* setup, there wasn't enough memory (on an XT) to load in the editor.ã* So I read the manuals (Yes, I do read them occasionally!) and figuredã* out a way to use an External Editor by utilizing the Control Center'sã* NEW Open Architecture.ãã* First, copy this program into dBase's Startup Directory.ãã* You next have to change dBase's setup using DBSETUP at the DOS promptã* and load in the current configuration and then on the Files Menuã* change the option of PRGAPPLIC so that it readsã* "C:\DBASEIV\EDIT2.PRG". Once done, save the new configuration andã* exit to DOS. Then enter dBase in your usual way. Next, create orã* edit an existing program through the Control Center's Applicationã* Menu. The Control Center will execute this .PRG file (it willã* automatically compile it) and load up your Editor with the programã* ready to edit!ãã* ***Note***ã* This program will only work through the Control Center. If you typeã* "MODI COMM filename" at the DOT PROMPT, the original editor will beã* loaded as the Open Architecture only works with the Control Centerã* applications.ãã* Hope you enjoy this program!!!!ãã* Parameters passed from Control Center to Application Designerã* Panel Name, Filename (Programming in dBase IV - Chapter 17, pg 4)ããPARAMETERS cPanelName, cFileNameãã* Clear screen and turn on cursorã* (MODI COMM turns off cursor when loading and then turns it backã* on when editing - Why? I don't know. When I invoked my editor, Iã* found that the cursor had disappeared, so I included this Commandã* and my cursor came back!)ããCLEARãSET CURSOR ONãã* Store Editor's filename and dBase .PRG Filename to variable forã* Macro Executionãã* (You can enter your own Editor's file name here if you wish, justã* include the FULL PATH NAME just in case, and don't forget the SPACE!)ãã* uncomment this line for PRGCC or it will load CATALOG FILEã* STORE "" TO cFileNameãSTORE "D:\TP\TURBO " + cFileName TO cExecEditãã* Invoke RUN() function to swap out memoryããSTORE RUN("&cExecEdit",.T.) TO nRunãã* Change filename so we can erase .DBO file for proper compilingã* If creating a new file, no need to erase .DBO fileããIF .NOT. ISBLANK(cFileName)ã STORE SUBSTR(cFileName, 1, AT(".PRG", cFileName)) + "DBO" TO ;ã cExecEditãã* Erase the .DBO fileãã ERASE &cExecEditãENDIFãã* Return directly to Control Center instead of invoking Command EditorããRETURN TO MASTERãã* Endã 4 05-28-9313:51ALL SWAG SUPPORT TEAM FLIPLAY.PAS IMPORT 255 o {$G+}ããProgram FliPlayer;ãã{ v1.1 made by Thaco }ã{ (c) EPOS, August 1992 }ãããConstã CLOCK_HZ =4608; { Frequency of clock }ã MONItoR_HZ =70; { Frequency of monitor }ã CLOCK_SCALE =CLOCK_HZ div MONItoR_HZ;ãã BUFFERSIZE =$FFFE; { Size of the framebuffer, must be an even number }ã CDATA =$040; { Port number of timer 0 }ã CMODE =$043; { Port number of timers control Word }ã CO80 =$3; { Number For standard Text mode }ã KEYBOARD =28; { Numbers returned by PorT[$64] indicating what hardware caused inT 09/the - }ã MOUSE =60; { - number on PorT[$60] }ã MCGA =$13; { Number For MCGA mode }ã MCGACheck:Boolean =True; { Variable For MCGA checking }ã UseXMS:Boolean =True; { Variable For XMS usage }ã XMSError:Byte =0; { Variable indicating the errornumber returned from the last XMS operation }ããTypeã EMMStructure =Recordã BytestoMoveLo, { Low Word of Bytes to move. NB: Must be even! }ã BytestoMoveHi, { High Word of Bytes to move }ã SourceHandle, { Handle number of source (SH=0 => conventional memory) }ã SourceoffsetLo, { Low Word of source offset, or ofS if SH=0 }ã SourceoffsetHi, { High Word of source offset, or SEG if SH=0 }ã DestinationHandle, { Handle number of destination (DH=0 => conventional memory) }ã DestinationoffsetLo, { Low Word of destination offset, or ofS if DH=0 }ã DestinationoffsetHi :Word; { High Word of destination offset, or SEG if DH=0 }ã end;ã HeaderType =Array[0..128] of Byte; { A bufferType used to read all kinds of headers }ãããVarã Key, { Variable used to check if a key has been pressed }ã OldKey :Byte; { Variable used to check if a key has been pressed }ã XMSRecord :EMMStructure; { Variable For passing values to the XMS routine }ã InputFile :File; { Variable For the incomming .FLI File }ã Header :HeaderType; { Buffer used to read all kinds of headers }ã Counter, { General purpose counter }ã Speed :Integer; { Timedifference in video tics from one frame to the next }ã FileCounter, { Variable telling the point to read from in the File stored in XMS }ã FileSize, { Size of the .FLI-File }ã FrameSize, { Variable indicating the datasize of current frame }ã NextTime, { Variable saying when it is time to move on to the next frame }ã TimeCounter, { Holding the current time in video tics }ã SecondPos :LongInt; { Number of Bytes to skip from the start of the .FLI File when starting - }ã { - from the beginning again }ã Buffer, { Pointer to the Framebuffer }ã XMSEntryPoint :Pointer; { Entry point of the XMS routine in memory }ã SpeedString :String[2]; { String used to parse the -sNN command }ã FileName :String[13]; { String holding the name of the .FLI-File }ã BufferHandle, { Handle number returned from the XMS routine }ã BytesRead, { Variable telling the numbers of Bytes read from the .FLI File }ã FrameNumber, { Number of the current frame }ã Frames, { total number of frames }ã Chunks :Word; { total number of chunks in a frame }ãããFunction UpCaseString(Streng:String):String;ã{ takes a String and convert all letters to upperCase }ãVarã DummyString :String;ã Counter :Integer;ãbeginã DummyString:='';ã For Counter:=1 to Length(Streng) doã DummyString:=DummyString+UpCase(Streng[Counter]);ã UpCaseString:=DummyString;ãend;ãããProcedure InitMode(Mode:Word); Assembler;ã{ Uses BIOS interrupts to set a videomode }ãAsmã mov ax,Modeã int 10hãend;ãããFunction ModeSupport(Mode:Word):Boolean; Assembler;ã{ Uses BIOS interrupts to check if a videomode is supported }ãLabel Exit, Last_Modes, No_Support, Supported;ãVarã DisplayInfo :Array[1..64] of Byte; { Array For storing Functionality/state inFormation }ãAsmã push esãã mov ah,1Bh { the Functionality/state inFormation request at int 10h }ã mov bx,0 { 0 = return Functionality/state inFormation }ã push ds { push DS on the stack and pop it into ES so ES:DI could be used to - }ã pop es { - address DisplayInfo, as demanded of the interrupt Function }ã mov di,offset DisplayInfoã int 10hãã les di,[dWord ptr es:di] { The first dWord in the buffer For state inFormation is the address - }ã { - of static funtionality table }ã mov cx,Mode { Can only check For the 0h-13h modes }ã cmp cx,13hã ja No_Support { Return 'no support' For modes > 13h }ãã mov ax,1 { Shift the right Byte the right - }ã { - times and test For the right - }ã cmp cx,10h { - bit For knowing if the - }ã jae Last_Modes { - videomode is supported - }ã { - }ã shl ax,cl { - }ã test ax,[Word ptr es:di+0] { - }ã jz No_Support { - }ã jmp Supported { - }ã { - }ãLast_Modes: { - }ã sub cx,10h { - }ã shl ax,cl { - }ã test al,[Byte ptr es:di+2] { - }ã jz No_Support { - }ããSupported:ã mov al,1 { AL=1 makes the Function return True }ã jmp ExitããNo_Support:ã mov al,0 { AL=0 makes the Function return True }ããExit:ã pop esãend;ãããFunction NoXMS:Boolean; Assembler;ã{ checks out if there is a XMS driver installed, and in Case it initialize theã XMSEntryPoint Variable }ãLabel JumpOver;ãAsmã push esãã mov ax,4300h { AX = 4300h => inSTALLATION CHECK }ã int 2Fh { use int 2Fh Extended MEMorY SPECifICATION (XMS) }ã mov bl,1 { use BL as a flag to indicate success }ã cmp al,80h { is a XMS driver installed? }ã jne JumpOverã mov ax,4310h { AX = 4310h => GET DRIVER ADDRESS }ã int 2Fhã mov [Word ptr XMSEntryPoint+0],BX { initialize low Word of XMSEntryPoint }ã mov [Word ptr XMSEntryPoint+2],ES { initialize high Word of XMSEntryPoint }ã mov bl,0 { indicate success }ãJumpOver:ã mov al,bl { make the Function return True (AH=1) or False (AH=0) }ãã pop esãend;ãããFunction XMSMaxAvail:Word; Assembler;ã{ returns size of largest contiguous block of XMS in kilo (1024) Bytes }ãLabel JumpOver;ãAsmã mov ah,08h { 'Query free Extended memory' Function }ã mov XMSError,0 { clear error Variable }ã call [dWord ptr XMSEntryPoint]ã or ax,ax { check For error }ã jnz JumpOverã mov XMSError,bl { errornumber stored in BL }ãJumpOver: { AX=largest contiguous block of XMS }ãend;ãããFunction XMSGetMem(SizeInKB:Word):Word; Assembler;ã{ allocates specified numbers of kilo (1024) Bytes of XMS and return a handleã to this XMS block }ãLabel JumpOver;ãAsmã mov ah,09h { 'Allocate Extended memory block' Function }ã mov dx,SizeInKB { number of KB requested }ã mov XMSError,0 { clear error Variable }ã call [dWord ptr XMSEntryPoint]ã or ax,ax { check For error }ã jnz JumpOverã mov XMSError,bl { errornumber stored in BL }ãJumpOver:ã mov ax,dx { return handle number to XMS block }ãend;ãããProcedure XMSFreeMem(Handle:Word); Assembler;ãLabel JumpOver;ãAsmã mov ah,0Ah { 'Free Extended memory block' Function }ã mov dx,Handle { XMS's handle number to free }ã mov XMSError,0 { clear error Variable }ã call [dWord ptr XMSEntryPoint]ã or ax,ax { check For error }ã jnz JumpOverã mov XMSError,bl { errornumber stored in BL }ãJumpOver:ãend;ãããProcedure XMSMove(Var EMMParamBlock:EMMStructure); Assembler;ãLabel JumpOver;ãAsmã push dsã push esã push dsã pop esã mov ah,0Bh { 'Move Extended memory block' Function }ã mov XMSError,0 { clear error Variable }ã lds si,EMMParamBlock { DS:SI -> data to pass to the XMS routine }ã call [dWord ptr es:XMSEntryPoint]ã or ax,ax { check For error }ã jnz JumpOverã mov XMSError,bl { errornumber stored in BL }ãJumpOver:ã pop esã pop dsãend;ãããProcedure ExitDuetoXMSError;ãbeginã InitMode(CO80);ã WriteLn('ERRor! XMS routine has reported error ',XMSError);ã XMSFreeMem(BufferHandle);ã Halt(0);ãend;ãããProcedure GetBlock(Var Buffer; Size:Word);ã{ reads a specified numbers of data from a diskFile or XMS into a buffer }ãVarã XMSRecord :EMMStructure;ã NumberofBytes :Word;ãbeginã if UseXMS thenã beginã NumberofBytes:=Size;ã if Size MOD 2=1 thenã Inc(NumberofBytes); { one must allways ask For a EQUAL number of Bytes }ã With XMSRecord doã beginã BytestoMoveLo :=NumberofBytes;ã BytestoMoveHi :=0;ã SourceHandle :=BufferHandle;ã SourceoffsetLo :=FileCounter MOD 65536;ã SourceoffsetHi :=FileCounter div 65536;ã DestinationHandle :=0;ã DestinationoffsetLo:=ofs(Buffer);ã DestinationoffsetHi:=Seg(Buffer);ã end;ã XMSMove(XMSRecord);ã if XMSError<>0 thenã ExitDuetoXMSError;ã Inc(FileCounter,Size);ã endã elseã BlockRead(InputFile,Buffer,Size);ãend;ãããProcedure InitClock; Assembler; {Taken from the FLILIB source}ãAsmã mov al,00110100b { put it into liNear count instead of divide by 2 }ã out CMODE,alã xor al,alã out CDATA,alã out CDATA,alãend;ãããFunction GetClock:LongInt; Assembler; {Taken from the FLILIB source}ã{ this routine returns a clock With occassional spikes where timeã will look like its running backwards 1/18th of a second. The resolutionã of the clock is 1/(18*256) = 1/4608 second. 66 ticks of this clockã are supposed to be equal to a monitor 1/70 second tick.}ãAsmã mov ah,0 { get tick count from Dos and use For hi 3 Bytes }ã int 01ah { lo order count in DX, hi order in CX }ã mov ah,dlã mov dl,dhã mov dh,clãã mov al,0 { read lo Byte straight from timer chip }ã out CMODE,al { latch count }ã mov al,1ã out CMODE,al { set up to read count }ã in al,CDATA { read in lo Byte (and discard) }ã in al,CDATA { hi Byte into al }ã neg al { make it so counting up instead of down }ãend;ãããProcedure TreatFrame(Buffer:Pointer;Chunks:Word); Assembler;ã{ this is the 'workhorse' routine that takes a frame and put it on the screen }ã{ chunk by chunk }ãLabelã Color_Loop, Copy_Bytes, Copy_Bytes2, Exit, Fli_Black, Fli_Brun, Fli_Color,ã Fli_Copy, Fli_Lc, Fli_Loop, Jump_Over, Line_Loop, Line_Loop2, Next_Line,ã Next_Line2, Pack_Loop, Pack_Loop2;ãAsmã cli { disable interrupts }ã push dsã push es ã lds si,Buffer { let DS:SI point at the frame to be drawn }ããFli_Loop: { main loop that goes through all the chunks in a frame }ã cmp Chunks,0 { are there any more chunks to draw? }ã je Exitã dec Chunks { decrement Chunks For the chunk to process now }ãã mov ax,[Word ptr ds:si+4] { let AX have the ChunkType }ã add si,6 { skip the ChunkHeader }ãã cmp ax,0Bh { is it a FLI_COLor chunk? }ã je Fli_Colorã cmp ax,0Ch { is it a FLI_LC chunk? }ã je Fli_Lcã cmp ax,0Dh { is it a FLI_BLACK chunk? }ã je Fli_Blackã cmp ax,0Fh { is it a FLI_BRUN chunk? }ã je Fli_Brunã cmp ax,10h { is it a FLI_COPY chunk? }ã je Fli_Copyã jmp Fli_Loop { This command should not be necessary since the Program should make one - }ã { - of the other jumps }ããFli_Color:ã mov bx,[Word ptr ds:si] { number of packets in this chunk (allways 1?) }ã add si,2 { skip the NumberofPackets }ã mov al,0 { start at color 0 }ã xor cx,cx { reset CX }ããColor_Loop:ã or bx,bx { set flags }ã jz Fli_Loop { Exit if no more packages }ã dec bx { decrement NumberofPackages For the package to process now }ãã mov cl,[Byte ptr ds:si+0] { first Byte in packet tells how many colors to skip }ã add al,cl { add the skiped colors to the start to get the new start }ã mov dx,$3C8 { PEL Address Write Mode Register }ã out dx,al { tell the VGA card what color we start changing }ãã inc dx { at the port abow the PEL_A_W_M_R is the PEL Data Register }ã mov cl,[Byte ptr ds:si+1] { next Byte in packet tells how many colors to change }ã or cl,cl { set the flags }ã jnz Jump_Over { if NumberstoChange=0 then NumberstoChange=256 }ã inc ch { CH=1 and CL=0 => CX=256 }ãJump_Over:ã add al,cl { update the color to start at }ã mov di,cx { since each color is made of 3 Bytes (Red, Green & Blue) we have to - }ã shl cx,1 { - multiply CX (the data counter) With 3 }ã add cx,di { - CX = old_CX shl 1 + old_CX (the fastest way to multiply With 3) }ã add si,2 { skip the NumberstoSkip and NumberstoChange Bytes }ã rep outsb { put the color data to the VGA card FAST! }ãã jmp Color_Loop { finish With this packet - jump back }ãããFli_Lc:ã mov ax,0A000hã mov es,ax { let ES point at the screen segment }ã mov di,[Word ptr ds:si+0] { put LinestoSkip into DI - }ã mov ax,di { - to get the offset address to this line we have to multiply With 320 - }ã shl ax,8 { - DI = old_DI shl 8 + old_DI shl 6 - }ã shl di,6 { - it is the same as DI = old_DI*256 + old_DI*64 = old_DI*320 - }ã add di,ax { - but this way is faster than a plain mul }ã mov bx,[Word ptr ds:si+2] { put LinestoChange into BX }ã add si,4 { skip the LinestoSkip and LinestoChange Words }ã xor cx,cx { reset cx }ããLine_Loop:ã or bx,bx { set flags }ã jz Fli_Loop { Exit if no more lines to change }ã dec bxãã mov dl,[Byte ptr ds:si] { put PacketsInLine into DL }ã inc si { skip the PacketsInLine Byte }ã push di { save the offset address of this line }ããPack_Loop:ã or dl,dl { set flags }ã jz Next_Line { Exit if no more packets in this line }ã dec dlã mov cl,[Byte ptr ds:si+0] { put BytestoSkip into CL }ã add di,cx { update the offset address }ã mov cl,[Byte ptr ds:si+1] { put BytesofDatatoCome into CL }ã or cl,cl { set flags }ã jns Copy_Bytes { no SIGN means that CL number of data is to come - }ã { - else the next data should be put -CL number of times }ã mov al,[Byte ptr ds:si+2] { put the Byte to be Repeated into AL }ã add si,3 { skip the packet }ã neg cl { Repeat -CL times }ã rep stosbã jmp Pack_Loop { finish With this packet }ããCopy_Bytes: ã add si,2 { skip the two count Bytes at the start of the packet }ã rep movsbã jmp Pack_Loop { finish With this packet }ããNext_Line:ã pop di { restore the old offset address of the current line }ã add di,320 { offset address to the next line }ã jmp Line_LoopãããFli_Black:ã mov ax,0A000hã mov es,ax { let ES:DI point to the start of the screen }ã xor di,diã mov cx,32000 { number of Words in a screen }ã xor ax,ax { color 0 is to be put on the screen }ã rep stoswã jmp Fli_Loop { jump back to main loop }ãããFli_Brun:ã mov ax,0A000hã mov es,ax { let ES:DI point at the start of the screen }ã xor di,diã mov bx,200 { numbers of lines in a screen }ã xor cx,cxããLine_Loop2:ã mov dl,[Byte ptr ds:si] { put PacketsInLine into DL }ã inc si { skip the PacketsInLine Byte }ã push di { save the offset address of this line }ããPack_Loop2:ã or dl,dl { set flags }ã jz Next_Line2 { Exit if no more packets in this line }ã dec dlã mov cl,[Byte ptr ds:si] { put BytesofDatatoCome into CL }ã or cl,cl { set flags }ã js Copy_Bytes2 { SIGN meens that CL number of data is to come - }ã { - else the next data should be put -CL number of times }ã mov al,[Byte ptr ds:si+1] { put the Byte to be Repeated into AL }ã add si,2 { skip the packet }ã rep stosbã jmp Pack_Loop2 { finish With this packet }ããCopy_Bytes2:ã inc si { skip the count Byte at the start of the packet }ã neg cl { Repeat -CL times }ã rep movsbã jmp Pack_Loop2 { finish With this packet }ããNext_Line2:ã pop di { restore the old offset address of the current line }ã add di,320 { offset address to the next line }ã dec bx { any more lines to draw? }ã jnz Line_Loop2ã jmp Fli_Loop { jump back to main loop }ãããFli_Copy:ã mov ax,0A000hã mov es,ax { let ES:DI point to the start of the screen }ã xor di,diã mov cx,32000 { number of Words in a screen }ã rep movswã jmp Fli_Loop { jump back to main loop }ãããExit:ã sti { enable interrupts }ã pop esã pop dsãend;ããããbeginã WriteLn;ã WriteLn('.FLI-Player v1.1 by Thaco');ã WriteLn(' (c) EPOS, August 1992');ã WriteLn;ã if ParamCount=0 then { if no input parameters then Write the 'usage Text' }ã beginã WriteLn('USAGE: FLIPLAY ');ã WriteLn(' '+#24+' '+#24);ã WriteLn(' ³ ÀÄÄ Filename of .FLI File');ã WriteLn(' ÀÄÄÄÄÄÄÄÄÄÄÄÄ -d = Do not use XMS');ã WriteLn(' -i = InFormation about the Program');ã WriteLn(' -n = No checking of MCGA mode support');ã WriteLn(' -sNN = Set playspeed to NN video ticks (0-99)');ã WriteLn(' ( NN=70 ÷ frame Delay of 1 second )');ã Halt(0);ã end;ãã For Counter:=1 to ParamCount do { search through the input parameters For a -Info option }ã if Pos('-I',UpCaseString(ParamStr(Counter)))<>0 thenã beginã WriteLn('Program inFormation:');ã WriteLn('This Program plays animations (sequences of pictures) made by Programs like',#10#13,ã 'Autodesk Animator (so called .FLI-Files). The Program decodes the .FLI File,',#10#13,ã 'frame by frame, and Uses the systemclock For mesuring the time-Delay between',#10#13,ã 'each frame.');ã WriteLn('Basis For the Program was the FliLib package made by Jim Kent, but since the',#10#13,ã 'original source was written in C, and I am not a good C-Writer, I decided',#10#13,ã 'to Write my own .FLI-player in Turbo Pascal v6.0.');ã WriteLn('This Program was made by Eirik Milch Pedersen ([email protected]).');ã WriteLn('Copyright Eirik Pedersens Own SoftwareCompany (EPOS), August 1992');ã WriteLn;ã WriteLn('Autodesk Animator is (c) Autodesk Inc');ã WriteLn('FliLib is (c) Dancing Flame');ã WriteLn('Turbo Pascal is (c) Borland International Inc');ã Halt(0);ã end;ãã Speed:=-1;ã Counter:=1;ã While (Copy(ParamStr(Counter),1,1)='-') and (ParamCount>=Counter) do { search through the input parameters to assemble them }ã beginã if Pos('-D',UpCaseString(ParamStr(Counter)))<>0 then { do not use XMS For storing the File into memory }ã UseXMS:=Falseã elseã if Pos('-N',UpCaseString(ParamStr(Counter)))<>0 then { do not check For a vga card present }ã MCGACheck:=Falseã elseã if Pos('-S',UpCaseString(ParamStr(Counter)))<>0 then { speed override has been specified }ã beginã SpeedString:=Copy(ParamStr(Counter),3,2); { cut out the NN parameter }ã if not(SpeedString[1] in ['0'..'9']) or { check if the NN parameter is legal }ã (not(SpeedString[2] in ['0'..'9',' ']) and (Length(SpeedString)=2)) thenã beginã WriteLn('ERRor! Can not parse speed ''',SpeedString,'''.');ã Halt(0);ã end;ã Speed:=Byte(SpeedString[1])-48; { take the first number, in ASCII, and convert it to a standard number }ã if Length(SpeedString)=2 then { if there is two numbers then multiply the first With 10 and add the next }ã Speed:=Speed*10+Byte(SpeedString[2])-48;ã Speed:=Speed*CLOCK_SCALE; { convert the speed to number of clock tics }ã end;ã Inc(Counter);ã end;ãã if ParamCount0 then { has an error occured during opening the File? }ã beginã WriteLn('ERRor! Can not open File ''',FileName,'''.');ã Halt(0);ã end;ãã if not(MCGACheck) or ModeSupport(MCGA) thenã InitMode(MCGA)ã elseã beginã WriteLn('ERRor! Video mode 013h - 320x200x256 colors - is not supported.');ã Halt(0);ã end;ãã BlockRead(InputFile,Header,128); { read the .FLI main header }ãã if not((Header[4]=$11) and (Header[5]=$AF)) then { check if the File has got the magic number }ã beginã InitMode(CO80);ã WriteLn('ERRor! File ''',FileName,''' is of a wrong File Type.');ã Halt(0);ã end;ãã if NoXMS then { if no XMS driver present then do not use XMS }ã UseXMS:=False;ãã if UseXMS thenã beginã FileSize:=Header[0]+256*(LongInt(Header[1])+256*(LongInt(Header[2])+256*LongInt(Header[3])));ã if XMSMaxAvail<=(FileSize+1023) SHR 10 then { is there enough XMS (rounded up to Nearest KB) availible? }ã beginã WriteLn('ERRor! not enough XMS For the File');ã Halt(0);ã endã elseã beginã Seek(InputFile,0); { skip back to start of .FLI-File to put it all into XMS }ã BufferHandle:=XMSGetMem((FileSize+1023) SHR 10); { allocate XMS For the whole .FLI File }ã FileCounter:=0;ã Repeatã BlockRead(InputFile,Buffer^,BUFFERSIZE,BytesRead); { read a part from the .FLI File }ã if BytesRead MOD 2=1 then { since BUFFERSIZE shoud be an even number, the only time this triggers is the last part }ã Inc(BytesRead); { must be done because the XMS routine demands an even number of Bytes to be moved }ã if BytesRead<>0 thenã beginã With XMSRecord do { put data into the XMSRecord }ã beginã BytestoMoveLo :=BytesRead;ã BytestoMoveHi :=0;ã SourceHandle :=0;ã SourceoffsetLo :=ofs(Buffer^);ã SourceoffsetHi :=Seg(Buffer^);ã DestinationHandle :=BufferHandle;ã DestinationoffsetLo:=FileCounter MOD 65536;ã DestinationoffsetHi:=FileCounter div 65536;ã end;ã XMSMove(XMSRecord); { move Bytes to XMS }ã if XMSError<>0 then { have any XMS errors occured? }ã ExitDuetoXMSError;ã Inc(FileCounter,BytesRead); { update the offset into XMS where to put the next Bytes }ã end;ã Until BytesRead<>BUFFERSIZE; { Repeat Until Bytes read <> Bytes tried to read => end of File }ã end;ã FileCounter:=128; { we continue (after reading the .FLI File into XMS) right after the .FLI main header }ã end;ãã Frames:=Header[6]+Header[7]*256; { get the number of frames from the .FLI-header }ã if Speed=-1 then { if speed is not set by a speed override then get it from the .FLI-header }ã Speed:=(Header[16]+Integer(Header[17])*256)*CLOCK_SCALE;ã InitClock; { initialize the System Clock }ã OldKey:=PorT[$60]; { get the current value from the keyboard }ã Key:=OldKey; { and set the 'current key' Variable to the same value }ãã GetBlock(Header,16); { read the first frame-header }ã FrameSize:=Header[0]+256*(LongInt(Header[1])+256*(LongInt(Header[2])+256*LongInt(Header[3])))-16; { calculate framesize }ã SecondPos:=128+16+FrameSize; { calculate what position to skip to when the .FLI is finished and is going to start again - }ã { the position = .FLI-header + first_frame-header + first_framesize }ã Chunks:=Header[6]+Header[7]*256; { calculate number of chunks in frame }ã GetBlock(Buffer^,FrameSize); { read the frame into the framebuffer }ã TreatFrame(Buffer,Chunks); { treat the first frame }ãã TimeCounter:=GetClock; { get the current time }ãã {ã The first frame must be handeled separatly from the rest. This is because the rest of the frames are updates/changes of theã first frame.ã At the end of the .FLI-File there is one extra frame who handles the changes from the last frame to the first frame.ã }ãã Repeatã FrameNumber:=1; { we start at the first frame (after the initial frame) }ã Repeatã GetBlock(Header,16); { read frame-header }ã FrameSize:=Header[0]+256*(LongInt(Header[1])+256*(LongInt(Header[2])+256*LongInt(Header[3])))-16; { size of frame }ã if FrameSize<>0 then { sometimes there are no changes from one frame to the next (used For extra Delays). In such - }ã { - Cases the size of the frame is 0 and we don't have to process them }ã beginã Chunks:=Header[6]+Header[7]*256; { calculate number of chunks in the frame }ã GetBlock(Buffer^,FrameSize); { read the frame into the framebuffer }ã TreatFrame(Buffer,Chunks); { treat the frame }ã end;ãã NextTime:=TimeCounter+Speed; { calculate the Delay to the next frame }ã While TimeCounterFrames) or (Key<>OldKey); { Repeated Until we come to the last frame or a key is pressed }ãã if UseXMS thenã FileCounter:=SecondPosã elseã Seek(InputFile,SecondPos); { set current position in the File to the second frame }ãã Until Key<>OldKey; { Exit the loop if a key has been pressed }ãã InitMode(CO80); { get back to Text mode }ãã Close(InputFile); { be a kind boy and close the File beFore we end the Program }ã FreeMem(Buffer,BUFFERSIZE); { and free the framebuffer }ãã if UseXMS thenã XMSFreeMem(BufferHandle);ãEND. 5 05-28-9313:51ALL SWAG SUPPORT TEAM GLOBALS.PAS IMPORT 146 oÐ Unit globals;ãã{ Use this Unit For Procedures, Functions and Variables that every Program youã Write will share.ã}ããInterfaceããUses ã Dos;ã ãTypeã str1 = String[1]; str2 = String[2]; str3 = String[3];ã str4 = String[4]; str5 = String[5]; str6 = String[6];ã str7 = String[7]; str8 = String[8]; str9 = String[9];ã str10 = String[10]; str11 = String[11]; str12 = String[12];ã str13 = String[13]; str14 = String[14]; str15 = String[15];ã str16 = String[16]; str17 = String[17]; str18 = String[18];ã str19 = String[19]; str20 = String[20]; str21 = String[21];ã str22 = String[22]; str23 = String[23]; str24 = String[24];ã str25 = String[25]; str26 = String[26]; str27 = String[27];ã str28 = String[28]; str29 = String[29]; str30 = String[30];ã str31 = String[31]; str32 = String[32]; str33 = String[33];ã str34 = String[34]; str35 = String[35]; str36 = String[36];ã str37 = String[37]; str38 = String[38]; str39 = String[39];ã str40 = String[40]; str41 = String[41]; str42 = String[42];ã str43 = String[43]; str44 = String[44]; str45 = String[45];ã str46 = String[46]; str47 = String[47]; str48 = String[48];ã str49 = String[49]; str50 = String[50]; str51 = String[51];ã str52 = String[52]; str53 = String[53]; str54 = String[54];ã str55 = String[55]; str56 = String[56]; str57 = String[57];ã str58 = String[58]; str59 = String[59]; str60 = String[60];ã str61 = String[61]; str62 = String[62]; str63 = String[63];ã str64 = String[64]; str65 = String[65]; str66 = String[66];ã str67 = String[67]; str68 = String[68]; str69 = String[69];ã str70 = String[70]; str71 = String[71]; str72 = String[72];ã str73 = String[73]; str74 = String[74]; str75 = String[75];ã str76 = String[76]; str77 = String[77]; str78 = String[78];ã str79 = String[79]; str80 = String[80]; str81 = String[81];ã str82 = String[82]; str83 = String[83]; str84 = String[84];ã str85 = String[85]; str86 = String[86]; str87 = String[87];ã str88 = String[88]; str89 = String[89]; str90 = String[90];ã str91 = String[91]; str92 = String[92]; str93 = String[93];ã str94 = String[94]; str95 = String[95]; str96 = String[96];ã str97 = String[97]; str98 = String[98]; str99 = String[99];ã str100 = String[100]; str101 = String[101]; str102 = String[102];ã str103 = String[103]; str104 = String[104]; str105 = String[105];ã str106 = String[106]; str107 = String[107]; str108 = String[108];ã str109 = String[109]; str110 = String[110]; str111 = String[111];ã str112 = String[112]; str113 = String[113]; str114 = String[114];ã str115 = String[115]; str116 = String[116]; str117 = String[117];ã str118 = String[118]; str119 = String[119]; str120 = String[120];ã str121 = String[121]; str122 = String[122]; str123 = String[123];ã str124 = String[124]; str125 = String[125]; str126 = String[126];ã str127 = String[127]; str128 = String[128]; str129 = String[129];ã str130 = String[130]; str131 = String[131]; str132 = String[132];ã str133 = String[133]; str134 = String[134]; str135 = String[135];ã str136 = String[136]; str137 = String[137]; str138 = String[138];ã str139 = String[139]; str140 = String[140]; str141 = String[141];ã str142 = String[142]; str143 = String[143]; str144 = String[144];ã str145 = String[145]; str146 = String[146]; str147 = String[147];ã str148 = String[148]; str149 = String[149]; str150 = String[150];ã str151 = String[151]; str152 = String[152]; str153 = String[153];ã str154 = String[154]; str155 = String[155]; str156 = String[156];ã str157 = String[157]; str158 = String[158]; str159 = String[159];ã str160 = String[160]; str161 = String[161]; str162 = String[162];ã str163 = String[163]; str164 = String[164]; str165 = String[165];ã str166 = String[166]; str167 = String[167]; str168 = String[168];ã str169 = String[169]; str170 = String[170]; str171 = String[171];ã str172 = String[172]; str173 = String[173]; str174 = String[174];ã str175 = String[175]; str176 = String[176]; str177 = String[177];ã str178 = String[178]; str179 = String[179]; str180 = String[180];ã str181 = String[181]; str182 = String[182]; str183 = String[183];ã str184 = String[184]; str185 = String[185]; str186 = String[186];ã str187 = String[187]; str188 = String[188]; str189 = String[189];ã str190 = String[190]; str191 = String[191]; str192 = String[192];ã str193 = String[193]; str194 = String[194]; str195 = String[195];ã str196 = String[196]; str197 = String[197]; str198 = String[198];ã str199 = String[199]; str200 = String[200]; str201 = String[201];ã str202 = String[202]; str203 = String[203]; str204 = String[204];ã str205 = String[205]; str206 = String[206]; str207 = String[207];ã str208 = String[208]; str209 = String[209]; str210 = String[210];ã str211 = String[211]; str212 = String[212]; str213 = String[213];ã str214 = String[214]; str215 = String[215]; str216 = String[216];ã str217 = String[217]; str218 = String[218]; str219 = String[219];ã str220 = String[220]; str221 = String[221]; str222 = String[222];ã str223 = String[223]; str224 = String[224]; str225 = String[225];ã str226 = String[226]; str227 = String[227]; str228 = String[228];ã str229 = String[229]; str230 = String[230]; str231 = String[231];ã str232 = String[232]; str233 = String[233]; str234 = String[234];ã str235 = String[235]; str236 = String[236]; str237 = String[237];ã str238 = String[238]; str239 = String[239]; str240 = String[240];ã str241 = String[241]; str242 = String[242]; str243 = String[243];ã str244 = String[244]; str245 = String[245]; str246 = String[246];ã str247 = String[247]; str248 = String[248]; str249 = String[249];ã str250 = String[250]; str251 = String[251]; str252 = String[252];ã str253 = String[253]; str254 = String[254]; str255 = String[255];ããConstã MaxWord = $ffff;ã MinWord = 0;ã MinInt = Integer($8000);ã MinLongInt = $80000000;ã UseCfg = True;ãã {Color Constants:ã Black = 0; Blue = 1; Green = 2; Cyan = 3; Red = 4;ã Magenta = 5; Brown = 6; LtGray = 7;ã DkGray = 8; LtBlue = 9; LtGreen = A; LtCyan = B; LtRed = C;ã LtMagenta = D; Yellow = E; White = Fã }ããConst Blink = $80;ãã {Screen color Constants}ãConst BlackOnBlack = $00; BlueOnBlack = $01;ãConst BlackOnBlue = $10; BlueOnBlue = $11;ãConst BlackOnGreen = $20; BlueOnGreen = $21;ãConst BlackOnCyan = $30; BlueOnCyan = $31;ãConst BlackOnRed = $40; BlueOnRed = $41;ãConst BlackOnMagenta = $50; BlueOnMagenta = $51;ãConst BlackOnBrown = $60; BlueOnBrown = $61;ãConst BlackOnLtGray = $70; BlueOnLtGray = $71;ãConst GreenOnBlack = $02; CyanOnBlack = $03;ãConst GreenOnBlue = $12; CyanOnBlue = $13;ãConst GreenOnGreen = $22; CyanOnGreen = $23;ãConst GreenOnCyan = $32; CyanOnCyan = $33;ãConst GreenOnRed = $42; CyanOnRed = $43;ãConst GreenOnMagenta = $52; CyanOnMagenta = $53;ãConst GreenOnBrown = $62; CyanOnBrown = $63;ãConst GreenOnLtGray = $72; CyanOnLtGray = $73;ãConst RedOnBlue = $14; MagentaOnBlue = $15;ãConst RedOnGreen = $24; MagentaOnGreen = $25;ãConst RedOnCyan = $34; MagentaOnCyan = $35;ãConst RedOnRed = $44; MagentaOnRed = $45;ãConst RedOnMagenta = $54; MagentaOnMagenta = $55;ãConst RedOnBrown = $64; MagentaOnBrown = $65;ãConst RedOnLtGray = $74; MagentaOnLtGray = $75;ãConst BrownOnBlack = $06; LtGrayOnBlack = $07;ãConst BrownOnBlue = $16; LtGrayOnBlue = $17;ãConst BrownOnGreen = $26; LtGrayOnGreen = $27;ãConst BrownOnCyan = $36; LtGrayOnCyan = $37;ãConst BrownOnRed = $46; LtGrayOnRed = $47;ãConst BrownOnMagenta = $56; LtGrayOnMagenta = $57;ãConst BrownOnBrown = $66; LtGrayOnBrown = $67;ãConst BrownOnLtGray = $76; LtGrayOnLtGray = $77;ãConst DkGrayOnBlack = $08; LtBlueOnBlack = $09;ãConst DkGrayOnBlue = $18; LtBlueOnBlue = $19;ãConst DkGrayOnGreen = $28; LtBlueOnGreen = $29;ãConst DkGrayOnCyan = $38; LtBlueOnCyan = $39;ãConst DkGrayOnRed = $48; LtBlueOnRed = $49;ãConst DkGrayOnMagenta = $58; LtBlueOnMagenta = $59;ãConst DkGrayOnBrown = $68; LtBlueOnBrown = $69;ãConst DkGrayOnLtGray = $78; LtBlueOnLtGray = $79;ãConst LtGreenOnBlack = $0A; LtCyanOnBlack = $0B;ãConst LtGreenOnBlue = $1A; LtCyanOnBlue = $1B;ãConst LtGreenOnGreen = $2A; LtCyanOnGreen = $2B;ãConst LtGreenOnCyan = $3A; LtCyanOnCyan = $3B;ãConst LtGreenOnRed = $4A; LtCyanOnRed = $4B;ãConst LtGreenOnMagenta = $5A; LtCyanOnMagenta = $5B;ãConst LtGreenOnBrown = $6A; LtCyanOnBrown = $6B;ãConst LtGreenOnLtGray = $7A; LtCyanOnLtGray = $7B;ãConst LtRedOnBlue = $1C; LtMagentaOnBlue = $1D;ãConst LtRedOnGreen = $2C; LtMagentaOnGreen = $2D;ãConst LtRedOnCyan = $3C; LtMagentaOnCyan = $3D;ãConst LtRedOnRed = $4C; LtMagentaOnRed = $4D;ãConst LtRedOnMagenta = $5C; LtMagentaOnMagenta = $5D;ãConst LtRedOnBrown = $6C; LtMagentaOnBrown = $6D;ãConst LtRedOnLtGray = $7C; LtMagentaOnLtGray = $7D;ãConst YellowOnBlack = $0E; WhiteOnBlack = $0F;ãConst YellowOnBlue = $1E; WhiteOnBlue = $1F;ãConst YellowOnGreen = $2E; WhiteOnGreen = $2F;ãConst YellowOnCyan = $3E; WhiteOnCyan = $3F;ãConst YellowOnRed = $4E; WhiteOnRed = $4F;ãConst YellowOnMagenta = $5E; WhiteOnMagenta = $5F;ãConst YellowOnBrown = $6E; WhiteOnBrown = $6F;ãConst YellowOnLtGray = $7E; WhiteOnLtGray = $7F;ãConst BlackOnDkGray = Blink + $00; BlueOnDkGray = Blink + $01;ãConst BlackOnLtBlue = Blink + $10; BlueOnLtBlue = Blink + $11;ãConst BlackOnLtGreen = Blink + $20; BlueOnLtGreen = Blink + $21;ãConst BlackOnLtCyan = Blink + $30; BlueOnLtCyan = Blink + $31;ãConst BlackOnLtRed = Blink + $40; BlueOnLtRed = Blink + $41;ãConst BlackOnLtMagenta = Blink + $50; BlueOnLtMagenta = Blink + $51;ãConst BlackOnYellow = Blink + $60; BlueOnYellow = Blink + $61;ãConst BlackOnWhite = Blink + $70; BlueOnWhite = Blink + $71;ãConst GreenOnDkGray = Blink + $02; CyanOnDkGray = Blink + $03;ãConst GreenOnLtBlue = Blink + $12; CyanOnLtBlue = Blink + $13;ãConst GreenOnLtGreen = Blink + $22; CyanOnLtGreen = Blink + $23;ãConst GreenOnLtCyan = Blink + $32; CyanOnLtCyan = Blink + $33;ãConst GreenOnLtRed = Blink + $42; CyanOnLtRed = Blink + $43;ãConst GreenOnLtMagenta = Blink + $52; CyanOnLtMagenta = Blink + $53;ãConst GreenOnYellow = Blink + $62; CyanOnYellow = Blink + $63;ãConst GreenOnWhite = Blink + $72; CyanOnWhite = Blink + $73;ãConst RedOnDkGray = Blink + $04; MagentaOnDkGray = Blink + $05;ãConst RedOnLtBlue = Blink + $14; MagentaOnLtBlue = Blink + $15;ãConst RedOnLtGreen = Blink + $24; MagentaOnLtGreen = Blink + $25;ãConst RedOnLtCyan = Blink + $34; MagentaOnLtCyan = Blink + $35;ãConst RedOnLtRed = Blink + $44; MagentaOnLtRed = Blink + $45;ãConst RedOnLtMagenta = Blink + $54; MagentaOnLtMagenta= Blink + $55;ãConst RedOnYellow = Blink + $64; MagentaOnYellow = Blink + $65;ãConst RedOnWhite = Blink + $74; MagentaOnWhite = Blink + $75;ãConst BrownOnDkGray = Blink + $06; LtGrayOnDkGray = Blink + $07;ãConst BrownOnLtBlue = Blink + $16; LtGrayOnLtBlue = Blink + $17;ãConst BrownOnLtGreen = Blink + $26; LtGrayOnLtGreen = Blink + $27;ãConst BrownOnLtCyan = Blink + $36; LtGrayOnLtCyan = Blink + $37;ãConst BrownOnLtRed = Blink + $46; LtGrayOnLtRed = Blink + $47;ãConst BrownOnLtMagenta = Blink + $56; LtGrayOnLtMagenta = Blink + $57;ãConst BrownOnYellow = Blink + $66; LtGrayOnYellow = Blink + $67;ãConst BrownOnWhite = Blink + $76; LtGrayOnWhite = Blink + $77;ãConst DkGrayOnDkGray = Blink + $08; LtBlueOnDkGray = Blink + $09;ãConst DkGrayOnLtBlue = Blink + $18; LtBlueOnLtBlue = Blink + $19;ãConst DkGrayOnLtGreen = Blink + $28; LtBlueOnLtGreen = Blink + $29;ãConst DkGrayOnLtCyan = Blink + $38; LtBlueOnLtCyan = Blink + $39;ãConst DkGrayOnLtRed = Blink + $48; LtBlueOnLtRed = Blink + $49;ãConst DkGrayOnLtMagenta = Blink + $58; LtBlueOnLtMagenta = Blink + $59;ãConst DkGrayOnYellow = Blink + $68; LtBlueOnYellow = Blink + $69;ãConst DkGrayOnWhite = Blink + $78; LtBlueOnWhite = Blink + $79;ãConst LtGreenOnDkGray = Blink + $0A; LtCyanOnDkGray = Blink + $0B;ãConst LtGreenOnLtBlue = Blink + $1A; LtCyanOnLtBlue = Blink + $1B;ãConst LtGreenOnLtGreen = Blink + $2A; LtCyanOnLtGreen = Blink + $2B;ãConst LtGreenOnLtCyan = Blink + $3A; LtCyanOnLtCyan = Blink + $3B;ãConst LtGreenOnLtRed = Blink + $4A; LtCyanOnLtRed = Blink + $4B;ãConst LtGreenOnLtMagenta= Blink + $5A; LtCyanOnLtMagenta = Blink + $5B;ãConst LtGreenOnYellow = Blink + $6A; LtCyanOnYellow = Blink + $6B;ãConst LtGreenOnWhite = Blink + $7A; LtCyanOnWhite = Blink + $7B;ãConst LtRedOnDkGray = Blink + $0C; LtMagentaOnDkGray = Blink + $0D;ãConst LtRedOnLtBlue = Blink + $1C; LtMagentaOnLtBlue = Blink + $1D;ãConst LtRedOnLtGreen = Blink + $2C; LtMagentaOnLtGreen= Blink + $2D;ãConst LtRedOnLtCyan = Blink + $3C; LtMagentaOnLtCyan = Blink + $3D;ãConst LtRedOnLtRed = Blink + $4C; LtMagentaOnLtRed = Blink + $4D;ãConst LtRedOnLtMagenta = Blink + $5C; LtMagentaOnLtMagenta= Blink + $5D;ãConst LtRedOnYellow = Blink + $6C; LtMagentaOnYellow = Blink + $6D;ãConst LtRedOnWhite = Blink + $7C; LtMagentaOnWhite = Blink + $7D;ãConst YellowOnDkGray = Blink + $0E; WhiteOnDkGray = Blink + $0F;ãConst YellowOnLtBlue = Blink + $1E; WhiteOnLtBlue = Blink + $1F;ãConst YellowOnLtGreen = Blink + $2E; WhiteOnLtGreen = Blink + $2F;ãConst YellowOnLtCyan = Blink + $3E; WhiteOnLtCyan = Blink + $3F;ãConst YellowOnLtRed = Blink + $4E; WhiteOnLtRed = Blink + $4F;ãConst YellowOnLtMagenta = Blink + $5E; WhiteOnLtMagenta = Blink + $5F;ãConst YellowOnYellow = Blink + $6E; WhiteOnYellow = Blink + $6F;ãConst YellowOnWhite = Blink + $7E; WhiteOnWhite = Blink + $7F;ããVarã TempStr : String;ã TempStrLen : Byte Absolute TempStr;ã ãFunction Exist(fn: str80): Boolean;ã{ Returns True if File fn exists in the current directory }ããFunction ExistsOnPath(Var fn: str80): Boolean;ã{ Returns True if File fn exists in any directory specified in the current }ã{ path and changes fn to a fully qualified path/File. }ããFunction StrUpCase(s : String): String;ã{ Returns an upper Case String from s. Applicable to the English language. }ããFunction StrLowCase(s : String): String;ã{ Returns a String = to s With all upper Case Characters converted to lower }ããFunction Asc2Str(Var s; max: Byte): String;ã{ Converts an ASCIIZ String to a Turbo Pascal String With a maximum length }ã{ of max Characters. }ããProcedure Str2Asc(s: String; Var ascStr; max: Word);ã{ Converts a TP String to an ASCIIZ String of no more than max length. }ã{ WARNinG: No checks are made that there is sufficient room in destination }ã{ Variable. }ããFunction LastPos(ch: Char; s: String): Byte;ã{ Returns the last position of ch in s }ããProcedure CheckIO(a: Byte);ããImplementationããFunction Exist(fn: str80): Boolean;ã beginã TempStrLen := 0;ã TempStr := FSearch(fn,'');ã Exist := TempStrLen <> 0;ã end; { Exist }ããFunction ExistsOnPath(Var fn: str80): Boolean;ã beginã TempStrLen := 0;ã TempStr := FSearch(fn,GetEnv('PATH'));ã ExistsOnPath := TempStrLen <> 0;ã fn := FExpand(TempStr);ã end; { ExistsOnPath }ããFunction StrUpCase(s : String): String;ã Var x : Byte;ã beginã StrUpCase[0] := s[0];ã For x := 1 to length(s) doã StrUpCase[x] := UpCase(s[x]);ã end; { StrUpCase }ããFunction StrLowCase(s : String): String;ã Var x : Byte;ã beginã StrLowCase[0] := s[0];ã For x := 1 to length(s) doã Case s[x] ofã 'a'..'z': StrLowCase[x] := chr(ord(s[x]) and $df);ã else StrLowCase[x] := s[x];ã end; { Case }ã end; { StrLowCase }ããFunction Asc2Str(Var s; max: Byte): String;ã Var stArray : Array[1..255] of Char Absolute s;ã len : Integer;ã beginã len := pos(#0,stArray)-1; { Get the length }ã if (len > max) or (len < 0) then { length exceeds maximum }ã len := max; { so set to maximum }ã Asc2Str := stArray;ã Asc2Str[0] := chr(len); { Set length }ã end; { Asc2Str }ããProcedure Str2Asc(s: String; Var ascStr; max: Word);ã beginã FillChar(AscStr,max,0);ã if length(s) < max thenã move(s[1],AscStr,length(s))ã elseã move(s[1],AscStr,max);ã end; { Str2Asc }ãããFunction LastPos(ch: Char; s: String): Byte;ã Var x : Word;ã beginã x := succ(length(s));ã Repeatã dec(x);ã Until (s[x] = ch) or (x = 0);ã end; { LastPos }ããProcedure CheckIO(a: Byte);ã Var e : Integer;ã beginã e := Ioresult;ã if e <> 0 then beginã Writeln('I/O error ',e,' section ',a);ã halt(e);ã end;ã end; { CheckIO }ããend. { Globals }ã ã 6 05-28-9313:51ALL SWAG SUPPORT TEAM HEBREW.PAS IMPORT 118 oÈ {ãDAVID SOLLYããFrom Israel Moshe Harel was heard to say to David SollyããThank you For taking the time to answer my many questions. I have toãtell you, though, that I was lucky to have received your letter becauseãit was addressed to David SALLY and not David SOLLY.ãã> Are you familiar With a Hebrew Text processor Program called QText?ã> I have been able to obtain version 2.10 as public domain software but Iã> am wondering if there has been an update. Have you ever heard of aããMH>Current version of QText is 5.0 and it is commercial :-(ã >It comes now With a full set of utilities, including FAX support.ããDid you know that Q-Text version 2.10 was written in Turbo Pascal 3? Iãwonder if Itschak Maynts (Isaac Mainz?) has continued to use it in hisãlater versions. Anyway, I would be interested in obtaining the latestãversion of Q-Text. Can you give me the distributor's address and theãapproximate price? Thank you.ãã>Most Israeli Printers have a special ROM. You may use downloadable Characterã>sets or even Graphic printing if needed. I once used LETTRIX For this purposã>on a Hebrew-less Printer, and it worked fine (but S L O W . . .).ãããI have Letrix 3.6. This was what I was trying to use to print theãQ-Text Files I was writing. I wrote a Program in Turbo Pascal toãconvert the Q-Text Files into Letrix Files. The printing is slow butãthe results are favourable. Another advantage to Letrix Hebrew Files isãthat they are written completely in low-ASCII and almost readableãwithout transliteration if one is at all familiar With Hebrew. It is aãgood format For posting Hebrew Text on the Multi-Lingual echo not onlyãbecause it is low-ASCII but also because the method of transliterationãis consistent.ããBelow is my Q-Text File to Letrix File conversion Program. I hope youãwill find it useful.ã}ããProgram QTextLetrix;ãã{$D-}ããUsesã Crt, Dos;ãããVarã InFile,ã TransFile : Text;ã InFilenm,ã TransFilenm : PathStr;ã Letter, Ans : Char;ã Printable,ã Hebrew,ã Niqud,ã Roman : Set of Char;ã Nkdm, Rom : Boolean;ãã{ã "UpItsCase" is a Function that takes a sting of any length andã sets all of the Characters in the String to upper case. It is handyã For comparing Strings.ã}ããFunction UpItsCase (SourceStr : PathStr) : PathStr;ãVarã i : Integer;ãbeginã For i := 1 to length(SourceStr) doã SourceStr[i] := UpCase(SourceStr[i]);ã UpItsCase := SourceStrãend; {Function UpItsCase}ãããFunction Exist(fname : PathStr) : Boolean;ãVarã f : File;ãbeginã{$F-,I-}ã Assign(f, fname);ã Reset(f);ã Close(f);ã{$I+}ã Exist := (IOResult = 0) and (fname <> '')ãend; {Function exist}ããProcedure Help;ãbeginã Writeln;ã Writeln ('QTLT (Version 1.0)');ã Writeln ('Hebrew Text File Conversion');ã Writeln ('Q-Text 2.10 File to Letrix(R) 3.6 Hebrew File');ã Writeln;ã Writeln;ã Writeln ('QTLT converts Q-Text Files to Letrix Hebrew format Files.');ã Writeln;ã Writeln ('QTLT expects two parameters on the command line.');ã Writeln ('The first parameter is the name of the File to convert,');ã Writeln ('the second is the name of the new File.');ã Writeln;ã Writeln ('Example: QTLT HKVTL.HEB HKVTL.TXT');ã Writeln;ã Writeln ('If no parameters are found, QTLT will display this message.');ã Writeln;ã Halt;ãend; {Procedure Help}ãã{ã "ParseCommandLine" is a Procedure that checks if any data was inputã at the Dos command line. If no data is there, then the "Help"ã Procedure is executed and the Program is halted. Otherwise, theã Mode strig Variable is set equal to the Text on the command line.ã}ããProcedure ParseCommandLine;ãbeginã if (ParamCount = 0) or (ParamCount <> 2) thenã Helpã elseã beginã InFilenm := ParamStr(1);ã InFilenm := UpItsCase(InFilenm);ã TransFilenm := ParamStr(2);ã TransFilenm := UpItsCase(TransFilenm);ã end;ãend; {Procedure ParseCommandLine}ããProcedure OpenFiles;ãbeginã {Open input/output Files}ã If not exist(InFilenm) thenã beginã Writeln;ã Writeln (InFilenm, ' not found');ã Halt;ã endã Elseã beginã Assign (InFile, InFilenm);ã Reset (InFile);ã end;ãã If exist (TransFilenm) thenã beginã Writeln;ã Writeln (TransFilenm, ' already exists!');ã Write ('OverWrite it? (Y/N) > ');ã Repeatã Ans := ReadKey;ã Ans := Upcase(Ans);ã If Ans = 'N' then Halt;ã Until Ans = 'Y';ã end;ãã Assign (TransFile, TransFilenm);ã ReWrite (TransFile);ã Writeln;ãend; {Procedure OpenFiles}ããããProcedure UseOfRoman;ãbeginã Writeln ('QTLT has detected Roman letters in the source Text.');ã Writeln;ã Writeln ('Letrix expects access to a Roman font to print these Characters');ã Writeln ('otherwise Letrix will report an error condition of fail to perform.');ã Writeln;ã Writeln ('Sample Letrix load instruction: LX Hebrew Roman');ã Writeln;ã Writeln ('Be sure that these instances are enclosed within the proper');ã Writeln ('Letrix font switch codes so they are not printed as Hebrew Character');ã Writeln;ãend; {Procedure UseOfRoman}ããProcedure Niqudim (Var Letter : Char);ã{ã Letrix Uses some standard Characters to represent niqudimã While Q-Text does not.ãã This table ensures that certain Characters do not becomeã niqudim when translated to Letrix by inserting the tokensã which instruct the Letrix Program to use the alternateã alphabet -- which by default is number 2.ã}ãbeginã If Not Nkdm thenã beginã Writeln;ã Writeln ('QTLT has detected Q-Text Characters which Letrix normaly Uses for');ã Writeln ('has transcribed them to print as normal Characters.');ã Writeln;ã Writeln ('Letrix expects access a Roman font to print these Characters');ã Writeln ('otherwise Letrix will report an error condition of fail to perfect');ã Writeln;ã Writeln ('Sample Letrix load instruction: LX Hebrew Roman');ã Writeln;ã Nkdm := True;ã end; {if not Nkdm}ãã Case Letter ofãã '!' : Write (TransFile, '\2!\1');ã '@' : Write (TransFile, '\2@\1');ã '#' : Write (TransFile, '\2#\1');ã '$' : Write (TransFile, '\2$\1');ã '%' : Write (TransFile, '\2%\1');ã '^' : Write (TransFile, '\2^\1');ã '&' : Write (TransFile, '\2&\1');ã '*' : Write (TransFile, '\2*\1');ã '(' : Write (TransFile, '\2(\1');ã ')' : Write (TransFile, '\2)\1');ã '+' : Write (TransFile, '\2+\1');ã '=' : Write (TransFile, '\2=\1');ãã end; {Case}ããend; {Procedure Nikudim}ããããProcedure QT_Table (Var Letter : Char);ã{ã This section reviews each QText letter and matches it With aã Letrix equivalent where possibleã}ãbeginã Case Letter ofãã #128 : Write (TransFile, 'a'); {Alef}ã #129 : Write (TransFile, 'b'); {Bet }ã #130 : Write (TransFile, 'g'); {Gimmel etc. }ã #131 : Write (TransFile, 'd');ã #132 : Write (TransFile, 'h');ã #133 : Write (TransFile, 'w');ã #134 : Write (TransFile, 'z');ã #135 : Write (TransFile, 'H');ã #136 : Write (TransFile, 'T');ã #137 : Write (TransFile, 'y');ã #138 : Write (TransFile, 'C');ã #139 : Write (TransFile, 'c');ã #140 : Write (TransFile, 'l');ã #141 : Write (TransFile, 'M');ã #142 : Write (TransFile, 'm');ã #143 : Write (TransFile, 'N');ã #144 : Write (TransFile, 'n');ã #145 : Write (TransFile, 'S');ã #146 : Write (TransFile, 'i');ã #147 : Write (TransFile, 'F');ã #148 : Write (TransFile, 'p');ã #149 : Write (TransFile, 'X');ã #150 : Write (TransFile, 'x');ã #151 : Write (TransFile, 'k');ã #152 : Write (TransFile, 'r');ã #153 : Write (TransFile, 's');ã #154 : Write (TransFile, 't');ãã end; {Case of}ããend; {Procedure QT_Table}ãããProcedure DoIt;ã{ã Special commands requred by Letrix.ã Proportional spacing off, line justification off,ã double-strike on, pitch set to 12 Characters per inch.ã}ãbeginãã Writeln(transFile,'\p\j\D\#12');ã {Transcription loop}ã While not eof(InFile) doã beginã Read(InFile, Letter);ãã If (Letter in Printable) thenã Write(TransFile, Letter);ãã If (Letter in Niqud) thenã Niqudim(Letter);ãã If (Letter in Hebrew) thenã QT_Table(Letter);ãã If (Letter in Roman) and (Rom = False) thenã beginã UseOfRoman;ã Rom := True;ã end; {Roman Detection}ãã end; {while}ãã {Close Files}ãã Close (TransFile);ã Close (InFile);ãã {Final message}ãã Writeln;ã Writeln;ã Writeln('QTLT (Version 1.0)');ã Writeln('Hebrew Text File Conversion');ã Writeln('Q-Text 2.10 Files to Letrix(R) 3.6 Hebrew File');ã Writeln;ã Writeln ('Task Complete');ã Writeln;ã Writeln ('QTLT was written and released to the public domain by David Solly');ã Writeln ('Bibliotheca Sagittarii, Ottawa, Canada (2 December 1992).');ã Writeln;ããend; {Procedure DoIt}ãããbeginãã {Initialize Variables}ã Printable := [#10,#12,#13,#32..#127];ã Roman := ['A'..'Z','a'..'z'];ã Niqud := ['!','@','#','$','%','^','&','*','(',')','+','='];ã Printable := Printable - Niqud;ã Hebrew := [#128..#154];ã Rom := False;ã Nkdm := False;ããParseCommandLine;ãOpenFiles;ãDoIt;ããend.ãã{ãã Please find below the Turbo Pascal source code For the conversionãProgram For making Letrix Hebrew Files into Q-Text 2.10 Files. I couldãnot find a way to make this conversion Program convert embedded RomanãText without making it into a monster. If you have any suggestions, Iãwould be thankful to the input.ãã========================= Cut Here ========================ã}ããProgram LetrixQText;ãã{$D-}ããUsesã Crt, Dos;ããVarã InFile,ã TransFile : Text;ã InFilenm,ã TransFilenm : PathStr;ã Letter, Ans : Char;ã Printable,ã HiASCII : Set of Char;ãã{ã "UpItsCase" is a Function that takes a sting of any length andã sets all of the Characters in the String to upper case. It is handyã For comparing Strings.ã}ããFunction UpItsCase (SourceStr : PathStr): PathStr;ãVarã i : Integer;ãbeginã For i := 1 to length(SourceStr) doã SourceStr[i] := UpCase(SourceStr[i]);ã UpItsCase := SourceStrãend; {Function UpItsCase}ãããFunction Exist(fname : PathStr) : Boolean;ãVarã f : File;ãbeginã {$F-,I-}ã Assign(f, fname);ã Reset(f);ã Close(f);ã {$I+}ã Exist := (IOResult = 0) and (fname <> '')ãend; {Function exist}ããProcedure Help;ãbeginã Writeln;ã Writeln ('LTQT (Version 1.0)');ã Writeln ('Hebrew Text File Conversion');ã Writeln ('Letrix(R) 3.6 File to Q-Text 2.10 File');ã Writeln;ã Writeln;ã Writeln ('LTQT converts Letrix Hebrew format Files to Q-Text format Files.')ã Writeln;ã Writeln ('LTQT expects two parameters on the command line.');ã Writeln ('The first parameter is the name of the File to convert,');ã Writeln ('the second is the name of the new File.');ã Writeln;ã Writeln ('Example: LTQT HKVTL.TXT HKVTL.HEB');ã Writeln;ã Writeln ('If no parameters are found, LTQT will display this message.');ã Writeln;ã Halt;ãend; {Procedure Help}ãã{ã "ParseCommandLine" is a Procedure that checks if any data was inputã at the Dos command line. If no data is there, then the "Help"ã Procedure is executed and the Program is halted. Otherwise, theã Mode strig Variable is set equal to the Text on the command line.ã}ãProcedure ParseCommandLine;ãbeginã if (ParamCount = 0) or (ParamCount <> 2) thenã Helpã elseã beginã InFilenm := ParamStr(1);ã InFilenm := UpItsCase(InFilenm);ã TransFilenm := ParamStr(2);ã TransFilenm := UpItsCase(TransFilenm);ã end;ãend; {Procedure ParseCommandLine}ããProcedure OpenFiles;ãbeginã {Open input/output Files}ã If not exist(InFilenm) thenã beginã Writeln;ã Writeln (InFilenm, ' not found');ã Halt;ã endã Elseã beginã Assign (InFile, InFilenm);ã Reset (InFile);ã end;ãã If exist (TransFilenm) thenã beginã Writeln;ã Writeln (TransFilenm, ' already exists!');ã Write ('OverWrite it? (Y/N) > ');ã Repeatã Ans := ReadKey;ã Ans := Upcase(Ans);ã If Ans = 'N' then Halt;ã Until Ans = 'Y';ã end;ãã Assign (TransFile, TransFilenm);ã ReWrite (TransFile);ã Writeln;ããend; {Procedure OpenFiles}ããããProcedure LT_Table (Var Letter : Char);ã{ã This section reviews each Letrix letter and matches it With aã Q-Text equivalent where possibleã}ãbeginã Case Letter ofãã 'a' : Write (TransFile, #128);ã 'b', 'B','v' : Write (TransFile, #129); {Vet, Bet}ã 'g' : Write (TransFile, #130);ã 'd' : Write (TransFile, #131);ã 'h' : Write (TransFile, #132);ã 'V', 'o', 'u', 'w' : Write (TransFile, #133); {Vav, Holem male, Shuruq}ã 'z' : Write (TransFile, #134);ã 'H' : Write (TransFile, #135);ã 'T' : Write (TransFile, #136);ã 'y', 'e' : Write (TransFile, #137); {Yod}ã 'C', 'Q', 'W' : Write (TransFile, #138); {Khaf-Sofit}ã 'c', 'K' : Write (TransFile, #139); {Khaf, Kaf}ã 'l' : Write (TransFile, #140);ã 'M' : Write (TransFile, #141);ã 'm' : Write (TransFile, #142);ã 'N' : Write (TransFile, #143);ã 'n' : Write (TransFile, #144);ã 'S' : Write (TransFile, #145);ã 'i' : Write (TransFile, #146);ã 'F' : Write (TransFile, #147);ã 'p', 'P', 'f' : Write (TransFile, #148); {Fe, Pe}ã 'X' : Write (TransFile, #149);ã 'x' : Write (TransFile, #150);ã 'k' : Write (TransFile, #151);ã 'r' : Write (TransFile, #152);ã 's' : Write (TransFile, #153);ã 't' : Write (TransFile, #154);ã 'A' : Write (TransFile, '-');ãã {Niqudim and unused letters}ãã 'D','E', 'G', 'I', 'J', 'j', 'O', 'q', 'R', 'U', 'Y', 'Z' :ã Write(TransFile, '');ã elseã Write(TransFile, Letter);ãã end; {Case of}ããend; {Procedure LT_Table}ãããProcedure DoIt;ãbeginã {Transcription loop}ã While not eof(InFile) doã beginã Read(InFile, Letter);ãã If (Letter in Printable) thenã LT_Table(Letter);ãã If (Letter in HiASCII) thenã Write(TransFile, Letter);ã end; {while}ãã {Close Files}ãã Close (TransFile);ã Close (InFile);ãã {Final message}ãã Writeln;ã Writeln;ã Writeln('LTQT Version 1.0');ã Writeln('Hebrew Text File Conversion');ã Writeln('Letrix(R) 3.6 File to Q-Text 2.10 File');ã Writeln;ã Writeln;ã Writeln ('Letrix Hebrew File to Q-Text File conversion complete.');ã Writeln;ã Writeln('Special Note:');ã Writeln;ã Writeln ('Q-Text does not support either dagesh or niqudim (vowels).');ã Writeln ('Letters containing a dagesh-qol are reduced to their simple form.');ã Writeln ('Holam male and shuruq are transcribed as vav. Roman letters used');ã Writeln ('to represent niqudim are ignored. All other symbols are transcribed'ã Writeln ('without change.');ã Writeln;ã Writeln ('There is no foreign language check -- Anything that can be transcribeã Writeln ('into Hebrew Characters will be.');ã Writeln;ã Writeln ('LTQT was written and released to the public domain by David Solly');ã Writeln ('Bibliotheca Sagittarii, Ottawa, Canada (8 December 1992).');ã Writeln;ããend; {Procedure DoIt}ãããbeginã {Initialize Variables}ã Printable := [#10,#12,#13,#32..#127];ã HiASCII := [#128..#154];ãã ParseCommandLine;ã OpenFiles;ã DoIt;ãend.ãã 7 05-28-9313:51ALL SWAG SUPPORT TEAM LONGJUMP.PAS IMPORT 22 oô6 Unit LongJump;ãã{ This Unit permits a long jump from deeply nested Procedures/Functions back }ã{ to a predetermined starting point. }ãã{ Whilst the purists may shudder at such a practice there are times when such}ã{ an ability can be exceedingly useful. An example of such a time is in a }ã{ BBS Program when the carrier may be lost unexpectedly whilst a user is on }ã{ line and the requirement is to "back out" to the initialisation reoutines }ã{ at the start of the Program. }ãã{ to use the facility, it is required that a call be made to the SetJump }ã{ Function at the point to where you wish the execution to resume after a }ã{ long jump. When the time comes to return to that point call FarJump. }ãã{ if you are an inexperienced Programmer, I do not recommend that this Unit }ã{ be used For other than experimentation. Usually there are better ways to }ã{ achieve what you want to do by proper planning and structuring. It is }ã{ rare to find a well written Program that will need such and ability. }ããInterfaceããConstã normal = -1; { return was not from a LongJump call }ãTypeã jumpType = Record { the data need For a return jump }ã bp,sp,cs,ip : Word;ã end;ããFunction SetJump(Var JumpData : jumpType): Integer;ãProcedure FarJump(JumpData : jumpType; IDInfo : Integer);ããImplementationããTypeã WordPtr = ^Word;ããFunction SetJump(Var JumpData : jumpType): Integer;ã begin { store the return address (the old bp register) }ã JumpData.bp := WordPtr(ptr(SSeg,SPtr+2))^;ã JumpData.ip := WordPtr(ptr(SSeg,SPtr+4))^;ã JumpData.cs := WordPtr(ptr(SSeg,SPtr+6))^;ã JumpData.SP := SPtr;ã SetJump := normal; { show that this is not a FarJump call }ã end; { SetJump }ããProcedure FarJump(JumpData : jumpType; IDInfo : Integer );ã beginã { change the return address of the calling routine of the stack so that }ã { a return can be made to the caller of SetJump }ã { Use IDInfo as an identifier of the routine the jump occurred from }ã WordPtr(ptr(SSeg,JumpData.SP))^ := JumpData.bp;ã WordPtr(ptr(SSeg,JumpData.SP+2))^ := JumpData.ip;ã WordPtr(ptr(SSeg,JumpData.SP+4))^ := JumpData.cs;ã Inline($8b/$46/$06); { mov ax,[bp+6] }ã Inline($8b/$ae/$fa/$ff); { mov bp,[bp-6] }ã end; { FarJump }ããend. { LongJump }ããã 8 05-28-9313:51ALL SWAG SUPPORT TEAM MAKEDATA.PAS IMPORT 7 oï {> I need about 10 megs of raw data and am looking For info-pascal archives.ã> Do they exist? ...and if so could someone please direct me to where I canãI wish everyone made such easy requests to fulfil. Try the followingãProgram. With minor changes, it will supply you With almost any amountãof data For which you could ask.ã}ãProgram GenerateData;ãUsesã Crt;ãConstã DataWanted = 3.0E5;ãVarã Data : File of Byte;ã Count : LongInt;ã Garbage : Byte;ãbeginã Assign(Data, 'Data.1MB');ã ReWrite(Data);ã Count := 0;ã Garbage := 1;ã For Count := 1 to Round(DataWanted) doã beginã Write(Data, garbage); (* smile *)ã GotoXY(1,1);ã Write(Count);ã Inc(Count);ã end;ã Close(Data)ãend.ã 9 05-28-9313:51ALL SWAG SUPPORT TEAM MAZE.PAS IMPORT 14 o¨ï {ãSEAN PALMERãã> Hello there.. I was just wondering.. Since I am completely 'C'ã> illiterate, could someone please make an effort and convert theã> following code in Pascal For me? (Its supposedly makes a solveableã> maze every time, Cool)ãã{originally by [email protected]}ã{Turbo Pascal conversion by Sean Palmer from original C}ããConstã h = 23; {height}ã w = 79; {width}ããConstã b : Array [0..3] of Integer = (-w, w, 1, -1);ã { incs For up, down, right, left }ããVarã a : Array [0..w * h - 1] of Boolean; { the maze (False = wall) }ããProcedure m(p : Integer);ãVarã i, d : Byte;ãbeginã a[p] := True; {make a path}ã Repeatã d := 0; {check For allowable directions}ã if (p > 2 * w) and not (a[p - w - w]) thenã inc(d, 1); {up}ã if (p < w * (h - 2)) and not (a[p + w + w]) thenã inc(d, 2); {down}ã if (p mod w <> w - 2) and not (a[p + 2]) thenã inc(d, 4); {right}ã if (p mod w <> 1) and not (a[p - 2]) thenã inc(d, 8); {left}ã if d <> 0 thenã beginã Repeat {choose a direction that's legal}ã i := random(4);ã Until Boolean(d and(1 shl i));ãã a[p + b[i]] := True; {make a path}ã m(p + 2 * b[i]); {recurse}ã end;ã Until d = 0; {Until stuck}ãend;ããVarã i : Integer;ããbeginã randomize;ã fillChar(a, sizeof(a), False);ã m(succ(w)); {start at upper left}ã For i := 0 to pred(w * h) doã begin {draw}ã if i mod w = 0 thenã Writeln;ã if a[i] thenã Write(' ')ã elseã Write('Û');ã end;ãend.ã 10 05-28-9313:51ALL SWAG SUPPORT TEAM MISCFUNC.PAS IMPORT 52 oãa Unit MiscFunc;ãã{ MiscFunc version 1.0 Scott D. Ramsay }ãã{ This is my misc. Function Unit. Some of the Functions have }ã{ nothing to do With games design but, my Units use it so ... }ã{ MiscFunc.pas is free. Go crazy. }ã{ I've been writing comments to these Units all night. Since you }ã{ have the source to this, I'll let you figure out what each one }ã{ does. }ããInterfaceããFunction strint(s:String):LongInt;ãFunction intstr(l:LongInt):String;ãFunction ups(s:String):String;ãFunction st(h:LongInt):String;ãFunction Compare(s1,s2:String):Boolean;ãFunction dtcmp(Var s1,s2;size:Word):Boolean;ãFunction lz(i,w:LongInt):String;ãFunction vl(h:String):LongInt;ãFunction spaces(h:Integer):String;ãFunction repstr(h:Integer;ch:Char):String;ãFunction anything(s:String):Boolean;ãFunction exist(f:String):Boolean;ãFunction errmsg(n:Integer):String;ãFunction turboerror(errorcode:Integer) : String;ãProcedure funpad(Var s:String);ãProcedure unpad(Var s:String);ãProcedure munpad(Var s:String;b:Byte);ãFunction fpad(s:String;h:Integer):String;ãProcedure pad(Var s:String;h:Integer);ãProcedure fix(Var s:String;h:String);ãProcedure fixh(Var s:String);ãFunction range(x,y,x1,y1,x2,y2:Integer) : Boolean;ãFunction between(x,x1,x2:Integer):Boolean;ããImplementationãããFunction range(x,y,x1,y1,x2,y2:Integer) : Boolean;ã{ returns True if (x,y) is in the rectangular region (x1,y1,x2,y2) }ãbeginã range := ((x>=x1) and (x<=x2) and (y>=y1) and (y<=y2));ãend;ãããProcedure fix(Var s:String;h:String);ãbeginã if pos('.',s)=0ã then s := s+h;ãend;ãããProcedure fixh(Var s:String);ãVarã d : Integer;ãbeginã For d := 1 to length(s) doã if s[d]<#32ã then s[d] := ' ';ã For d := length(s)+1 to 255 doã s[d] := ' ';ãend;ãããFunction strint(s:String):LongInt;ãVarã l : LongInt;ãbeginã move(s[1],l,sizeof(l));ã strint := l;ãend;ãããFunction intstr(l:LongInt):String;ãVarã s : String;ãbeginã move(l,s[1],sizeof(l));ã s[0] := #4;ã intstr := s;ãend;ãããFunction ups(s:String):String;ãVarã d : Integer;ãbeginã For d := 1 to length(s) doã s[d] := upCase(s[d]);ã ups := s;ãend;ãããFunction st(h:LongInt):String;ãVarã s : String;ãbeginã str(h,s);ã st := s;ãend;ãããFunction Compare(s1,s2:String):Boolean;ãVarã d : Byte;ã e : Boolean;ãbeginã e := True;ã For d := 1 to length(s1) doã if upCase(s1[d])<>upCase(s2[d])ã then e := False;ã Compare := e;ãend;ãããFunction dtcmp(Var s1,s2;size:Word):Boolean;ãVarã d : Word;ã e : Boolean;ãbeginã e := True;ã d := size;ã While (d>0) and e doã beginã dec(d);ã e := (mem[seg(s1):ofs(s1)+d]=mem[seg(s2):ofs(s2)+d]);ã end;ã dtcmp := e;ãend;ãããFunction lz(i,w:LongInt):String;ãVarã d : LongInt;ã s : String;ãbeginã str(i,s);ã For d := length(s) to w-1 doã s := concat('0',s);ã lz := s;ãend;ãããFunction vl(h:String):LongInt;ãVarã d : LongInt;ã e : Integer;ãbeginã val(h,d,e);ã vl := d;ãend;ãããFunction spaces(h:Integer):String;ãVarã s : String;ãbeginã s := '';ã While h>0 doã beginã dec(h);ã s := concat(s,' ');ã end;ã spaces := s;ãend;ãããFunction repstr(h:Integer;ch:Char):String;ãVarã s : String;ãbeginã s := '';ã While h>0 doã beginã dec(h);ã s := s+ch;ã end;ã repstr := s;ãend;ãããFunction anything(s:String):Boolean;ãVarã d : Integer;ã h : Boolean;ãbeginã if length(s)=0ã thenã beginã anything := False;ã Exit;ã end;ã h := False;ã For d := 1 to length(s) doã if s[d]>#32ã then h := True;ã anything := h;ãend;ãããFunction exist(f:String):Boolean;ãVarã fil : File;ãbeginã if f=''ã thenã beginã exist := False;ã Exit;ã end;ã assign(fil,f);ã {$i- }ã reset(fil);ã close(fil);ã {$i+ }ã exist := (ioresult=0);ãend;ãããFunction errmsg(n:Integer):String;ãbeginã Case n ofã -1 : errmsg := '';ã -2 : errmsg := 'Error reading data File';ã -3 : errmsg := '';ã -4 : errmsg := 'equal current data File name';ã 150 : errmsg := 'Disk is Write protected';ã 152 : errmsg := 'Drive is not ready';ã 156 : errmsg := 'Disk seek error';ã 158 : errmsg := 'Sector not found';ã 159 : errmsg := 'Out of Paper';ã 160 : errmsg := 'Error writing to Printer';ã 1000 : errmsg := 'Record too large';ã 1001 : errmsg := 'Record too small';ã 1002 : errmsg := 'Key too large';ã 1003 : errmsg := 'Record size mismatch';ã 1004 : errmsg := 'Key size mismatch';ã 1005 : errmsg := 'Memory overflow';ã else errmsg := 'Error result #'+st(n);ã end;ãend;ãããFunction turboerror(errorcode:Integer) : String;ãbeginã Case errorcode ofã 1: turboerror := 'Invalid Dos Function code';ã 2: turboerror := 'File not found';ã 3: turboerror := 'Path not found';ã 4: turboerror := 'too many open Files';ã 5: turboerror := 'File access denied';ã 6: turboerror := 'Invalid File handle';ã 8: turboerror := 'not enough memory';ã 12: turboerror := 'Invalid File access code';ã 15: turboerror := 'Invalid drive number';ã 16: turboerror := 'Cannot remove current directory';ã 17: turboerror := 'Cannot rename across drives';ã 100: turboerror := 'Disk read error';ã 101: turboerror := 'Disk Write error';ã 102: turboerror := 'File not assigned';ã 103: turboerror := 'File not open';ã 104: turboerror := 'File not open For input';ã 105: turboerror := 'File not open For output';ã 106: turboerror := 'Invalid numeric Format';ã 200: turboerror := 'division by zero';ã 201: turboerror := 'Range check error';ã 202: turboerror := 'Stack overflow error';ã 203: turboerror := 'Heap overflow error';ã 204: turboerror := 'Invalid Pointer operation';ã else turboerror := errmsg(errorcode);ã end;ãend;ãããProcedure funpad(Var s:String);ãbeginã While s[1]=' ' doã delete(s,1,1);ãend;ãããProcedure unpad(Var s:String);ãbeginã While (length(s)>0) and (s[length(s)]<=' ') doã delete(s,length(s),1);ãend;ãããProcedure munpad(Var s:String;b:Byte);ãbeginã s[0] := Char(b);ã While (length(s)>0) and (s[length(s)]<=' ') doã delete(s,length(s),1);ãend;ãããFunction fpad(s:String;h:Integer):String;ãbeginã While length(s)=x1) and (x<=x2));ãend;ãããend. 11 05-28-9313:51ALL SWAG SUPPORT TEAM PATCHEXE.PAS IMPORT 22 ow {ã>If this cannot be done, then hhow can one include a pcx directly insideã>the compiled File???ãã There's a trick to do that :ã Suppose your Program is called PROG.EXE and your PCX File IMAGE.PCXãã After each compile of PROG.EXE, do :ã COPY /B PROG.EXE+IMAGE.PCXãã Then, when you want to display the PCX, open the EXE File, read it'sã header :ã}ããFunction GetExeSize(ExeName:String; Var TotSize,Expect:LongInt):Boolean;ã{ returns True if EXE is already bind }ãTypeã ExeHeaderRec = Record {Information describing EXE File}ã Signature : Word; {EXE File signature}ã LengthRem : Word; {Number of Bytes in last page of EXE imageã LengthPages : Word; {Number of 512 Byte pages in EXE image}ã NumReloc : Word; {Number of relocation items}ã HeaderSize : Word; {Number of paraGraphs in EXE header}ã MinHeap,MaxHeap : Word; {ParaGraphs to keep beyond end of image}ã StackSeg,StackPtr : Word; {Initial SS:SP, StackSeg relative to imageã CheckSum : Word; {EXE File check sum, not used}ã IpInit, CodeSeg : Word; {Initial CS:IP, CodeSeg relative to imageã RelocOfs : Word; {Bytes into EXE For first relocation item}ã OverlayNum : Word; {Overlay number, not used here}ã end;ããVarã ExeF : File;ã ExeHeader : ExeHeaderRec;ã ExeValue : LongInt;ã count : Word;ããbeginã TotSize:=0; Expect:=0;ã Assign(ExeF,ExeName); Reset(ExeF,1);ã if IoResult=0 thenã beginã TotSize:=FileSize(ExeF);ã BlockRead(ExeF,ExeHeader,SizeOf(ExeHeaderRec),Count);ã With ExeHeader doã if Signature=$5A4D thenã beginã if LengthRem=0 thenã ExeValue:=LongInt(LengthPages) shl 9ã elseã ExeValue:=(LongInt(Pred(LengthPages)) shl 9)ã Expect:=ExeValue;ã end;ã end;ã Close(ExeF);ã GetExeSize:=(TotSize<>Expect);ãend;ãã{ã If GetExeSize returns True, your PCX has been placed at the end of theã EXE (you did not forget :)) and all you have to do next is skip theã Program itself : Seek(ExeF,Expect);ãã Then starts your PCX. If you know in advance the sizes of the PCXã File, you can place any data you want (including lots of PCX) at theã end of your EXE.ãã This example is taken from a Unit I wrote a long time ago (was calledã Caravane) and it worked very well. I accessed the end of my exe Fileã like a normal Typed File. Quite funny but I do not use this anymore.ã Note that you can LzExe or Pklite the EXE part (not the PCX one). Youã can DIET both parts With the resident version.ãã I hope the Function GetExeSize is not copyrighted since it is much tooã commented to be one of my work :)ã 12 05-28-9313:51ALL SWAG SUPPORT TEAM REBOOT1.PAS IMPORT 9 o²v { Subject: How to reboot With TP7.0 ??? }ãVarã hook : Word Absolute $0040:$0072;ããProcedure Reboot(Cold : Boolean); Far;ãbeginã if (Cold = True) thenã hook := $0000ã elseã hook := $1234;ãã ExitProc := ptr($FFFF,$0000);ãend;ããã{ãP.S. Note that it does not require any Units to compile. Thoughãdepending on your Implementation, you may need to call HALT toãtrip the Exit code (which caUses a reboot).ã}ããProgram reset;ãUsesã Dos;ãVarã regs : Registers;ãbeginã intr(25,regs);ãend.ãã{ Yeah but it is easier to do it in Inline Asmãeg:ã}ãProgram reset;ãbeginã Asmã INT 19h; {19h = 25 decimal}ã end;ãend.ãã{ãOne Word about this interupt is that it is the fastest rebootãI know of but some memory managers, eg QEMM 6.03 don't like it,ãIt will seriously hang Windows if called from a Dos Shell,ãMicrosoft Mouse Driver 8.20 doesn't seem to like being runãafter you call int 19h and it was resident.ãOther than that it works like a gem!ã}ã 13 05-28-9313:51ALL SWAG SUPPORT TEAM REBOOT2.PAS IMPORT 7 o¾w {ãKARIM SULTANããBelieve it or not, Int 19h is not he way to go. It will stimulate a warmãboot, but it is not very safe. It doesn't do some of the shutdown workãnecessary For some applications, and the preferred method is to set the Wordãat location 40:72 and to jump to $FFFF:0.ãHere are my Procedures For doing reboots from a Program:ã}ãProcedure ColdBoot; Assembler;ãAsmã Xor AX, AXã Mov ES, AXã Mov Word PTR ES:[472h],0000h {This is not a WARM boot}ã Mov AX, 0F000hã Push AXã Mov AX, 0FFF0hã Push AXã Retfãend;ããProcedure WarmBoot; Assembler;ãAsmã Xor AX, AXã Mov ES, AXã Mov Word PTR ES:[472h],1234h {This is not a COLD boot}ã Mov AX, 0F000hã Push AXã Mov AX, 0FFF0hã Push AXã Retfãend;ã 14 05-28-9313:51ALL SWAG SUPPORT TEAM REBOOT3.PAS IMPORT 4 oV {ãREYNIR STEFANSSONããFor anyone wondering how to reboot a PClone from Within Turbo Pascal:ãThe Inline code is a far jump to the restart vector at $FFFF:0.ã}ããProcedure ColdStart;ãbeginã MemW[$40:$72] := 0;ã Inline($EA/0/0/$FF/$FF);ãend;ããProcedure WarmStart;ãbeginã MemW[$40:$72] := $1234;ã Inline($EA/0/0/$FF/$FF);ãend;ãã 15 05-28-9313:51ALL SWAG SUPPORT TEAM SUNDRY.PAS IMPORT 99 o Unit sundry;ããInterfaceããUsesã Dos,ã sCrt,ã Strings;ããTypeã LongWds = Recordã loWord,ã hiWord : Word;ã end;ã ica_rec = Recordã Case Integer ofã 0: (Bytes : Array[0..15] of Byte);ã 1: (Words : Array[0..7] of Word);ã 2: (Integers: Array[0..7] of Integer);ã 3: (strg : String[15]);ã 4: (longs : Array[0..3] of LongInt);ã 5: (dummy : String[13]; chksum: Integer);ã 6: (mix : Byte; wds : Word; lng : LongInt);ã end;ã{-This simply creates a Variant Record which is mapped to 0000:04F0ã which is the intra-applications communications area in the bios areaã of memory. A Program may make use of any of the 16 Bytes in this areaã and be assured that Dos and the bios will not interfere With it. Thisã means that it can be effectively used to pass values/inFormationã between different Programs. It can conceivably be used to storeã inFormation from an application, then terminate from that application,ã run several other Programs, and then have another Program use theã stored inFormation. As the area can be used by any Program, it is wiseã to incorporate a checksum to ensure that the intermediate applicationsã have not altered any values. It is of most use when executing childã processes or passing values between related Programs that are runã consecutively.}ãã IOproc = Procedure(derror:Byte; msg : String);ããConstã ValidChars : String[40] = ' ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-'+#39;ã HexChars : Array[0..15] of Char = '0123456789ABCDEF';ããVarã ica : ica_rec Absolute $0000:$04f0;ã FilePosition : LongInt;ã(* OldRecSize : Word; *)ã TempStr : String;ããProcedure CheckIO(Error_action : IOproc; msg : String);ããFunction CompressStr(Var n): String;ã {-Will Compress 3 alpha-numeric Bytes into 2 Bytes}ããFunction DeCompress(Var s): String;ã {-DeCompresses a String Compressed by CompressStr}ããFunction NumbofElements(Var s; size : Word): Word;ã {-returns the number of active elements in a set}ããFunction PrinterStatus : Byte;ã {-Gets the Printer status}ããFunction PrinterReady(Var b : Byte): Boolean;ããFunction TestBbit(n,b: Byte): Boolean;ãFunction TestWbit(Var n; b: Byte): Boolean;ãFunction TestLbit(n: LongInt; b: Byte): Boolean;ããProcedure SetBbit(Var n: Byte; b: Byte);ãProcedure SetWbit(Var n; b: Byte);ãProcedure SetLbit(Var n: LongInt; b: Byte);ããProcedure ResetBbit(Var n: Byte; b: Byte);ãProcedure ResetWbit(Var n; b: Byte);ãProcedure ResetLbit(Var n: LongInt; b: Byte);ããFunction right(Var s; n : Byte): String;ãFunction left(Var s; n : Byte): String;ãFunction shleft(Var s; n : Byte): String;ãFunction nExtStr(Var s1; s2 : String; n : Byte): String;ãProcedure WriteAtCr(st: String; col,row: Byte);ãProcedure WriteLnAtCr(st: String; col,row: Byte);ãProcedure WriteLNCenter(st: String; width: Byte);ãProcedure WriteCenter(st: String; width: Byte);ãProcedure GotoCR(col,row: Byte);ãã {-These Functions and Procedures Unit provides the means to do randomã access reads on Text Files. }ããFunction Exist(fn : String) : Boolean;ããFunction Asc2Str(Var s; max: Byte): String;ããProcedure DisableBlink(State:Boolean);ããFunction Byte2Hex(numb : Byte) : String;ããFunction Numb2Hex(Var numb) : String;ããFunction Long2Hex(long : LongInt): String;ããFunction Hex2Byte(HexStr : String) : Byte;ããFunction Hex2Word(HexStr : String) : Word;ããFunction Hex2Integer(HexStr : String) : Integer;ããFunction Hex2Long(HexStr : String) : LongInt;ãã{======================================================================}ãããImplementationããProcedure CheckIO(error_action : IOproc;msg : String);ã Var c : Word;ã beginã c := Ioresult;ã if c <> 0 then error_action(c,msg);ã end;ããã{$F+}ãProcedure ReportError(c : Byte; st : String);ã beginã Writeln('I/O Error ',c);ã Writeln(st);ã halt(c);ã end;ã{$F-}ããFunction StUpCase(Str : String) : String;ãVarã Count : Integer;ãbeginã For Count := 1 to Length(Str) doã Str[Count] := UpCase(Str[Count]);ã StUpCase := Str;ãend;ããããFunction CompressStr(Var n): String;ã Varã S : String Absolute n;ã InStr : String;ã len : Byte Absolute InStr;ã Compstr: Recordã Case Byte ofã 0: (Outlen : Byte;ã OutArray: Array[0..84] of Word);ã 1: (Out : String[170]);ã end;ã temp,ã x,ã count : Word;ã beginã FillChar(InStr,256,32);ã InStr := S;ã len := (len + 2) div 3 * 3;ã FillChar(CompStr.Out,171,0);ã InStr := StUpCase(InStr);ã x := 1; count := 0;ã While x <= len do beginã temp := pos(InStr[x+2],ValidChars);ã inc(temp,pos(InStr[x+1],ValidChars) * 40);ã inc(temp,pos(InStr[x],ValidChars) * 1600);ã inc(x,3);ã CompStr.OutArray[count] := temp;ã inc(count);ã end;ã CompStr.Outlen := count shl 1;ã CompressStr := CompStr.Out;ã end; {-CompressStr}ããFunction DeCompress(Var s): String;ã Varã CompStr : Recordã clen : Byte;ã arry : Array[0..84] of Word;ã end Absolute s;ã x,ã count,ã temp : Word;ã beginã With CompStr do beginã DeCompress[0] := Char((clen shr 1) * 3);ã x := 0; count := 1;ã While x <= clen shr 1 do beginã temp := arry[x] div 1600;ã dec(arry[x],temp*1600);ã DeCompress[count] := ValidChars[temp];ã temp := arry[x] div 40;ã dec(arry[x],temp*40);ã DeCompress[count+1] := ValidChars[temp];ã temp := arry[x];ã DeCompress[count+2] := ValidChars[temp];ã inc(count,3);ã inc(x);ã end;ã end;ã end;ããFunction NumbofElements(Var s; size : Word): Word;ã {-The Variable s can be any set Type and size is the Sizeof(s)}ã Varã TheSet : Array[1..32] of Byte Absolute s;ã count,x,y : Word;ã beginã count := 0;ã For x := 1 to size doã For y := 0 to 7 doã inc(count, 1 and (TheSet[x] shr y));ã NumbofElements := count;ã end;ããFunction PrinterStatus : Byte;ã Var regs : Registers; {-from the Dos Unit }ã beginã With regs do beginã dx := 0; {-The Printer number LPT2 = 1 }ã ax := $0200; {-The Function code For service wanted }ã intr($17,regs); {-$17= ROM bios int to return Printer status}ã PrinterStatus := ah;{-Bit 0 set = timed out }ã end; { 1 = unused }ã end; { 2 = unused }ã { 3 = I/O error }ã { 4 = Printer selected }ã { 5 = out of paper }ã { 6 = acknowledge }ã { 7 = Printer not busy }ããFunction PrinterReady(Var b : Byte): Boolean;ã beginã b := PrinterStatus;ã PrinterReady := (b = $90) {-This may Vary between Printers}ã end;ããFunction TestBbit(n,b: Byte): Boolean;ã beginã TestBbit := odd(n shr b);ã end;ããFunction TestWbit(Var n; b: Byte): Boolean;ã Var t: Word Absolute n;ã beginã if b < 16 thenã TestWbit := odd(t shr b);ã end;ããFunction TestLbit(n: LongInt; b: Byte): Boolean;ã beginã if b < 32 thenã TestLbit := odd(n shr b);ã end;ããProcedure SetBbit(Var n: Byte; b: Byte);ã beginã if b < 8 thenã n := n or (1 shl b);ã end;ããProcedure SetWbit(Var n; b: Byte);ã Var t : Word Absolute n; {-this allows either a Word or Integer}ã beginã if b < 16 thenã t := t or (1 shl b);ã end;ããProcedure SetLbit(Var n: LongInt; b: Byte);ã beginã if b < 32 thenã n := n or (LongInt(1) shl b);ã end;ããProcedure ResetBbit(Var n: Byte; b: Byte);ã beginã if b < 8 thenã n := n and not (1 shl b);ã end;ããProcedure ResetWbit(Var n; b: Byte);ã Var t: Word Absolute n;ã beginã if b < 16 thenã t := t and not (1 shl b);ã end;ããProcedure ResetLbit(Var n: LongInt; b: Byte);ã beginã if b < 32 thenã n := n and not (LongInt(1) shl b);ã end;ããFunction right(Var s; n : Byte): String;ã Varã st : String Absolute s;ã len: Byte Absolute s;ã beginã if n >= len then right := st elseã right := copy(st,len+1-n,n);ã end;ããFunction shleft(Var s; n : Byte): String;ã Varã st : String Absolute s;ã stlen: Byte Absolute s;ã temp : String;ã len : Byte Absolute temp;ã beginã if n < stlen then beginã move(st[n+1],temp[1],255);ã len := stlen - n;ã shleft := temp;ã end;ã end;ããFunction left(Var s; n : Byte): String;ã Varã st : String Absolute s;ã temp: String;ã len : Byte Absolute temp;ã beginã temp := st;ã if n < len then len := n;ã left := temp;ã end;ããFunction nExtStr(Var s1;s2 : String; n : Byte): String;ã Varã main : String Absolute s1;ã second : String Absolute s2;ã len : Byte Absolute s2;ã beginã nExtStr := copy(main,pos(second,main)+len,n);ã end;ããProcedure WriteAtCr(st: String; col,row: Byte);ã beginã GotoXY(col,row);ã Write(st);ã end;ãããProcedure WriteLnAtCr(st: String; col,row: Byte);ã beginã GotoXY(col,row);ã Writeln(st);ã end;ããFunction Charstr(ch : Char; by : Byte) : String;ãVarã Str : String;ã Count : Integer;ãbeginã Str := '';ã For Count := 1 to by doã Str := Str + ch;ã CharStr := Str;ãend;ãããProcedure WriteLnCenter(st: String; width: Byte);ã beginã TempStr := CharStr(' ',(width div 2) - succ((length(st) div 2)));ã st := TempStr + st;ã Writeln(st);ã end;ããProcedure WriteCenter(st: String; width: Byte);ã beginã TempStr := CharStr(' ',(width div 2)-succ((length(st) div 2)));ã st := TempStr + st;ã Write(st);ã end;ããProcedure GotoCR(col,row: Byte);ã beginã GotoXY(col,row);ã end;ããFunction Exist(fn : String): Boolean;ã Varã f : File;ã OldMode : Byte;ã beginã OldMode := FileMode;ã FileMode:= 0;ã assign(f,fn);ã {$I-} reset(f,1); {$I+}ã if Ioresult = 0 then beginã close(f);ã Exist := True;ã endã elseã Exist := False;ã FileMode:= OldMode;ã end; {-Exist}ããFunction Asc2Str(Var s; max: Byte): String;ã Var stArray : Array[0..255] of Byte Absolute s;ã st : String;ã len : Byte Absolute st;ã beginã move(stArray[0],st[1],255);ã len := max;ã len := (max + Word(1)) * ord(pos(#0,st) = 0) + pos(#0,st)-1;ã Asc2Str := st;ã end;ãããProcedure DisableBlink(state : Boolean);ã { DisableBlink(True) allows use of upper eight colors as background }ã { colours. DisableBlink(False) restores the normal mode and should }ã { be called beFore Program Exit }ãVarã regs : Registers;ãbeginã With regs doã beginã ax := $1003;ã bl := ord(not(state));ã end;ã intr($10,regs);ãend; { DisableBlink }ããFunction Byte2Hex(numb : Byte) : String;ã beginã Byte2Hex[0] := #2;ã Byte2Hex[1] := HexChars[numb shr 4];ã Byte2Hex[2] := HexChars[numb and 15];ã end;ããFunction Numb2Hex(Var numb) : String;ã { converts an Integer or a Word to a String. Using an unTypedã argument makes this possible. }ã Var n : Word Absolute numb;ã beginã Numb2Hex := Byte2Hex(hi(n))+Byte2Hex(lo(n));ã end;ããFunction Long2Hex(long : LongInt): String;ã beginã With LongWds(long) do { Type casting makes the split up easy}ã Long2Hex := Numb2Hex(hiWord) + Numb2Hex(loWord);ã end;ããFunction Hex2Byte(HexStr : String) : Byte;ã beginã Hex2Byte := pos(UpCase(HexStr[2]),HexChars)-1 +ã ((pos(UpCase(HexStr[1]),HexChars))-1) shl 4 { * 16}ã end;ããFunction Hex2Word(HexStr : String) : Word;ã { This requires that the String passed is a True hex String of 4ã Chars and not in a Format like $FDE0 }ã beginã Hex2Word := pos(UpCase(HexStr[4]),HexChars)-1 +ã ((pos(UpCase(HexStr[3]),HexChars))-1) shl 4 + { * 16}ã ((pos(UpCase(HexStr[2]),HexChars))-1) shl 8 + { * 256}ã ((pos(UpCase(HexStr[1]),HexChars))-1) shl 12; { *4096}ã end;ããFunction Hex2Integer(HexStr : String) : Integer;ã beginã Hex2Integer := Integer(Hex2Word(HexStr));ã end;ããFunction Hex2Long(HexStr : String) : LongInt;ã Var Long : LongWds;ã beginã Long.hiWord := Hex2Word(copy(HexStr,1,4));ã Long.loWord := Hex2Word(copy(HexStr,5,4));ã Hex2Long := LongInt(Long);ã end;ããbeginã FilePosition := 0;ãend.ã 16 05-28-9313:51ALL SWAG SUPPORT TEAM TPASM.PAS IMPORT 79 oµV { Ok here it is.. I have disasembled the following TP Program toãshow you the inner workings of TP (well at least 6.0). TheãFolloing Program was Compiled in the IDE With RANGE, I/O, STACKãchecking turned off. Look at the code close and see if you canãfind a nasty little bug in it beFore I show you the Asm that TPãCreated on disk.ã}ããProgram TstFiles;ããType MyRec = Recordã LInt : LongInt;ã Hi : Word;ã Lo : Word;ã B1 : Byte;ã B2 : Byte;ã B3 : Byte;ã B4 : Byte;ã end; {Record Size 12 Bytes}ããConst MaxRecs = 100;ãããVar MyTypedFile : File of MyRec;ã MyUnTypedFile : File;ãã Rec : MyRec;ã RecCnt : Word;ãããProcedure FillRec (RecSeed : LongInt);ãã beginã Rec.Lint := RecSeed;ã Rec.Hi := Hi (Rec.Lint);ã Rec.Lo := Lo (Rec.Lint);ã Rec.B1 := Lo (Rec.Lo);ã Rec.B2 := Hi (Rec.Lo);ã Rec.B3 := Lo (Rec.Hi);ã Rec.B4 := Hi (Rec.Hi);ã end;ãããããbeginãAssign (MyTypedFile, 'Type.Dat');ãAssign (MyUnTypedFile, 'UnTyped.Dat');ãReWrite (MyTypedFile);ãReWrite (MyUnTypedFile);ããFor RecCnt := 1 to MaxRecs doã beginã FillRec (RecCnt);ãã Write (MyTypedFile , Rec);ã{ Write (MyUnTypedFile, Rec);} {Illegal can't do this}ãã FillRec (RecCnt + $FFFF);ãã{ BlockWrite (MyTypedFile, Rec, 1);} {Illegal Can't do this eather}ãã BlockWrite (MyUnTypedFile, Rec, Sizeof (MyRec));ã end;ãããend.ãããThe Asm Break down is in the next two messages...ããTSTFileS.38: beginã cs:0051 9A0000262D call 2D26:0000 <-------TP Start Up Codeã cs:0056 55 push bpã cs:0057 89E5 mov bp,spãTSTFileS.39: Assign (MyTypedFile, 'Type.Dat');ã cs:0059 BF4400 mov di,0044ã cs:005C 1E push dsã cs:005D 57 push diã cs:005E BF3C00 mov di,003Cã cs:0061 0E push csã cs:0062 57 push diã cs:0063 9AC004262D call 2D26:04C0 <-------TP's Routine to setã up File Records.ãTSTFileS.40: Assign (MyUnTypedFile, 'UnTyped.Dat');ã cs:0068 BFC400 mov di,00C4ã cs:006B 1E push dsã cs:006C 57 push diã cs:006D BF4500 mov di,0045ã cs:0070 0E push csã cs:0071 57 push diã cs:0072 9AC004262D call 2D26:04C0 <-------TP's Routine to setã up File Records.ãTSTFileS.41: ReWrite (MyTypedFile);ã cs:0077 BF4400 mov di,0044ã cs:007A 1E push dsã cs:007B 57 push diã cs:007C B80C00 mov ax,000Cã cs:007F 50 push axã cs:0080 9AF704262D call 2D26:04F7 <-------TP's Routine toã Create File.ãTSTFileS.42: ReWrite (MyUnTypedFile);ã cs:0085 BFC400 mov di,00C4ã cs:0088 1E push dsã cs:0089 57 push diã cs:008A B88000 mov ax,0080ã cs:008D 50 push axã cs:008E 9AF704262D call 2D26:04F7 <-------TP's Routine toã Create File.ãTSTFileS.44: For RecCnt := 1 to MaxRecs doã cs:0093 C70650010100 mov Word ptr [TSTFileS.RECCNT],00ã *** Clear the loop counter For first loopã cs:0099 EB04 jmp TSTFileS.46 (009F)ã *** Jump to the start of the Loopã cs:009B FF065001 inc Word ptr [TSTFileS.RECCNT]ã *** The Loop returns to here to inC the loop counterãTSTFileS.46: FillRec (RecCnt);ã cs:009F A15001 mov ax,[TSTFileS.RECCNT]ã *** Move our RecCnt Var into AX registerã cs:00A2 31D2 xor dx,dxã *** Clear the DX Registerã cs:00A4 52 push dxã cs:00A5 50 push axã *** Push the DX and AX Registers on the stack. Remember ourã FillRec Routine expects a LongInt to be passed and RecCntã is only a Word. So it Pushes the DX as the 0 Upper Wordã of the LongInt.ã cs:00A6 0E push csã *** Push the code segment For some reasion.ã cs:00A7 E856FF call TSTFileS.FILLRECã *** Call our FillRec RoutineãTSTFileS.48: Write (MyTypedFile , Rec);ã cs:00AA BF4400 mov di,0044ã cs:00AD 1E push dsã cs:00AE 57 push diã *** These instructions push the address of MyTypedFile Recordã on the stack. The first paramiterã cs:00AF BF4401 mov di,0144ã cs:00B2 1E push dsã cs:00B3 57 push diã *** These instructions push the address of Rec Recordã on the stack. The second paramiterã cs:00B4 9AAA05262D call 2D26:05AAã *** Call the System Function to Write a Typed File. (In next msg)ã cs:00B9 83C404 add sp,0004ã *** Remove our passed parameters from the stackãTSTFileS.51: FillRec (RecCnt + $FFFF);ã cs:00BC A15001 mov ax,[TSTFileS.RECCNT]ã cs:00BF 05FFFF add ax,FFFFã cs:00C2 31D2 xor dx,dxã cs:00C4 52 push dxã cs:00C5 50 push axã cs:00C6 0E push csã cs:00C7 E836FF call TSTFileS.FILLRECã *** Now heres a NASTY littel bug With the code!!! Look at theã above routine. We wanted to pass a LongInt $FFFF + rec cntã But we wound up adding the $FFFF to a Word then passing aã LongInt. if you Compile the sample pas File you'll be ableã to see this bug in action.. Good reasion to use a Debugger.ãTSTFileS.55: BlockWrite (MyUnTypedFile, Rec, Sizeof (MyRec))ã cs:00CA BFC400 mov di,00C4ã cs:00CD 1E push dsã cs:00CE 57 push diã *** These instructions push the address of MyUnTypeFile Recordã on the stack. The First paramiterã cs:00CF BF4401 mov di,0144ã cs:00D2 1E push dsã cs:00D3 57 push diã cs:0594 26817D02B3D7 cmp es:Word ptr [di+02],D7B3ã *** Armed With the address of the File Record in ES:DIã Check the File mode For a In/Out operation. See Dosã Unit Constant definitions.ã cs:059A 7406 je 05A2ã *** if that Compare was equal then jump to returnã cs:059C C7063C006700 mov Word ptr [SYSTEM.inOUTRES],0069ã *** if we didn't jump then put File not oopen For output inã Ioresult.ã cs:05A2 C3 retã *** Go back to where we were calledã cs:05A3 B43F mov ah,3Fã cs:05A5 BA6400 mov dx,0064ã cs:05A8 EB05 jmp 05AFãã *** The Write instruction entered the system Unit hereã cs:05AA B440 mov ah,40ã *** Load Dos Function in AHã cs:05AC BA6500 mov dx,0065ã *** Default error code 101 disk Write error load in DXã cs:05AF 55 push bpã *** Save the BP registerã cs:05B0 8BEC mov bp,spã *** Load the BP Register With the stack Pointerã cs:05B2 C47E0A les di,[bp+0A]ã *** Load Address of MyTypeFile Rec in ES:SIã cs:05B5 E8DCFF call 0594ã *** Call check For File mode. See top of messageã cs:05B8 751B jne 05D5ã *** if error jump out of thisã cs:05BA 1E push dsã cs:05BB 52 push dxã *** Save These Registers as we'er going to use themã cs:05BC C55606 lds dx,[bp+06]ã *** Load the address of our Rec in DS:DX Registersã cs:05BF 268B4D04 mov cx,es:[di+04]ã *** Look up Record structure For a File Rec and you'll seeã that RecSize is Byte # 4. Move that value to CXã cs:05C3 268B1D mov bx,es:[di]ã *** First Byte of a File Rec is the Handel. Move into BXã cs:05C6 CD21 int 21ã *** Make the Dos CALL to Write. AH = 40ã BX = File Handelã CX = # of Bytes to Write.ã DS:DX = Address of Bufferã Returns Error In AX if Carry flag set orã if good CF = 0 number of Bytes written in AXã cs:05C8 5A pop dxã cs:05C9 1F pop dsã *** Restore the Registersã cs:05CA 7206 jb 05D2ã *** Jump if there was an error (if Carry flag Set)ã cs:05CC 3BC1 cmp ax,cxã *** Comp Bytes requested to what was writtenã cs:05CE 7405 je 05D5ã *** if equal then jump out we'r just about doneã cs:05D0 8BC2 mov ax,dxã *** Move default errorcode 101 to AXã cs:05D2 A33C00 mov [SYSTEM.inOUTRES],ax <--Set Ioresultã *** Store 101 to Ioresultã cs:05D5 5D pop bpã *** Restore BP registerã cs:05D6 CA0400 retf 0004ã *** We'r out of hereãã cs:05D9 B33F mov bl,3Fã cs:05DB B96400 mov cx,0064ã cs:05DE EB05 jmp 05E5ããã *** The BlockWrite instruction entered the system Unit hereã cs:05E0 B340 mov bl,40ã *** Move Dos Function in BLã cs:05E2 B96500 mov cx,0065ã *** Default error 101 Write error in CXã cs:05E5 55 push bpã *** Save BP Registerã cs:05E6 8BEC mov bp,spã *** Move Stack Pointer to BPã cs:05E8 C47E10 les di,[bp+10]ã *** Load Address of MyUnTypedFile Record in ES:DIã cs:05EB E8A6FF call 0594ã *** Check For Open in Write Mode See top of messageã cs:05EE 753F jne 062Fã *** Jump if not in Write modeã cs:05F0 8B460A mov ax,[bp+0A] ]ã *** Move File Record cnt in to axã cs:05F3 0BC0 or ax,axã *** Check For 0 Record requestã cs:05F5 741C je 0613ã *** Jump if 0 rec requestedã cs:05F7 1E push dsã cs:05F8 51 push cxã *** Save them we'er going to use themã cs:05F9 26F76504 mul es:Word ptr [di+04]ã *** Multiply Record size With RecCnt in AX result in DX & AXã cs:05FD 8BC8 mov cx,axã 17 05-28-9313:51ALL SWAG SUPPORT TEAM ZTRAS.PAS IMPORT 33 oöJ Unit Globals;ããInterfaceããUses Crt{, Dos?};ãã{ Special keyboard Characters: }ã{ I've squeezed them into a couple of lines so that they'd fit in aãmessage.. might be an idea to expand them back to ~20 lines or so..}ãã NULL = #0; BS = #8; ForMFEED = #12; CR = #13; ESC = #27;ãã HOMEKEY = #199; {Values apply if only used With the 'Getkey' Function}ã endKEY = #207; UPKEY = #200; doWNKEY = #208;ã PGUPKEY = #201; PGDNKEY = #209; LEFTKEY = #203;ã inSKEY = #210; RIGHTKEY = #205; DELKEY = #211;ã CTRLLEFTKEY = #243; CTRLRIGHTKEY = #244;ã F1 = #187; F2 = #188; F3 = #189; F4 = #190; F5 = #191;ã F6 = #192; F7 = #193; F8 = #194; F9 = #195; F10 = #196;ããType CurType = ( off, Big, Small );ããVar Ins : Boolean; { Global Var containing status of Insert key}ãã{-----------------------------------------------------------------------------}ãFunction GetKey : Char;ãProcedure EdReadln(Var S : String);ããProcedure Cursor( Size : CurType ); { Either off, Big or Small }ãProcedure ChangeCursor( Ins : Boolean );ãã{-----------------------------------------------------------------------------}ãImplementationããFunction GetKey; { : Char; }ããVar C : Char;ããbeginã C := ReadKey;ã Repeatã if C = NULL thenã beginã C := ReadKey;ã if ord(C) > 127 thenã C := NULLã elseã GetKey := Chr(ord(C) + 128);ã end else GetKey := C;ã Until C <> NULL;ãend; { GetKey }ãã{-----------------------------------------------------------------------------}ãProcedure EdReadln; { (Var S : String); }ãã{ Legal : IString; MaxLength : Word; Var ESCPressed : Boolean); }ããVar CPos : Word;ã Ch : Char;ã OldY : Byte;ãã Legal : String[1];ã MaxLength : Byte;ã EscPressed : Boolean;ããbeginã OldY := WhereY - 1;ã ChangeCursor(Ins);ã CPos := 1; {Place cursor at START of line}ã{ CPos := Succ(Length(S));} {Whereas this places cursor at end of line}ã Legal := ''; {Legal and Maxlength originally passed as params}ã MaxLength := Lo( WindMax ) - Lo( WindMin );ãã Repeatã Cursor( off );ã GotoXY(1, WhereY);ã Write(S, '':(MaxLength - Length(S)));ã GotoXY(CPos, WhereY);ã ChangeCursor(Ins);ã Ch := GetKey;ã Case Ch ofã HOMEKEY : CPos := 1;ã endKEY : CPos := Succ(Length(S));ã inSKEY : beginã Ins := not Ins;ã ChangeCursor(Ins);ã end;ã LEFTKEY : if CPos > 1 then Dec(CPos);ã RIGHTKEY : if CPos <= Length(S) then Inc(CPos);ã BS : if CPos > 1 thenã beginã Delete(S, Pred(CPos), 1);ã Dec(CPos);ã end;ã DELKEY : if CPos <= Length(S) then Delete(S, CPos, 1);ã CR : ;ã ESC : beginã S := '';ã CPos := 1;ã end;ã elseã beginã if ((Legal = '') or (Pos(Ch, Legal) <> 0)) andã ((Ch >= ' ') and (Ch <= '~')) andã (Length(S) < MaxLength) thenã beginã if Ins then Insert(Ch, S, CPos) elseã if CPos > Length(S) then S := S + Ch elseã S[CPos] := Ch;ã Inc(CPos);ã end;ã end;ã end; { Case }ã Until (Ch = CR);ã Cursor( Small );ã ESCPressed := Ch <> ESC;ã Writeln;ãend; { EditString }ãã{-----------------------------------------------------------------------------}ãProcedure Cursor; { ( Size : CurType ); { Either off, Big or Small }ããVar Regs : Registers;ããbeginã With Regs Do beginã Ax := $100;ã Case Size ofã off : Cx := $3030;ã Big : Cx := $0F;ã Small : Cx := $607;ã end;ã Intr ( $10, Regs );ã end;ãend;ãã{-----------------------------------------------------------------------------}ãProcedure ChangeCursor; { ( Ins : Boolean ); }ã{Changes cursor size depending on status of insert key}ããbeginã if Ins then Cursor( Small ) else Cursor( Big );ãend;ããbeginãend.ã 18 05-10-9314:24ALL COLIN BUCKLEY Compiler Directives (232)T_Pascal_R 32 oi So I'm using a common include file, which I'll add to the end of this message,ãand I've noticed something very strange. I used the Object browser to findãall the units, and I have triple checked to ensure they all include theãinclude file and this is what I've found:ããWith DEBUGGING set my file compiles to 115KãWithout DEBUGGING set 81KããWhen I look at the file there is still loads of symbol information there.ãAfter TDStrip of the above file, it's down to 55K (81-55=26). That's a 26Kãdifference. Where is it coming from? Sure I'm using CRT and DOS, andãobviously the include file doesn't work for them, but after looking at theãremaining symbol information, it's alot of stuff from my various unitsãaswell as CRT and DOS.ããWhat's the deal with the symbols coming from my units when I tell themãnot to? I say symbols as it's all declarations from my interfaceãsections like variables and procedure names, etc.ããAnyways, I wasn't interested in using multiple configuration files, butãI guess I'll have to as I forgot about Borland units, and I guess everyoneãelse did aswell.ãã----------------------------- OPTIONS.INC --------------------------------ã{ãTurbo Pascal Compiler Directivesã}ãã{$DEFINE i286}ã{$DEFINE DEBUGGING}ãã{$A+} { Data Alignment........Word }ã{$I-} { I/O Checking..........Off }ã{$X-} { Enhanced Syntax.......Off }ã{$V-} { String Type Checking..Relaxed }ã{$P-} { Open Strings..........Off }ã{$T-} { @ Pointers............UnTyped }ãã{$IFDEF i286}ã{$G+} { 286 OpCodes...........On }ã{$ELSE}ã{$G-} { 286 OpCodes...........Off }ã{$ENDIF}ãã{$IFDEF OVERLAYS}ã{$F+} { Far Calls.............On }ã{$O+} { Overlays Allowed......Yes }ã{$ELSE}ã{$F-} { Far Calls.............Off }ã{$O-} { Overlays Allowed......No }ã{$ENDIF}ãã{$IFDEF DEBUGGING}ã{$B+} { Boolean Evaluation....Complete }ã{$D+} { Debugging Info........On }ã{$L+} { Line Numbers..........On }ã{$Y+} { Symbol Information....On }ã{$R+} { Range Checking........On }ã{$S+} { Stack Checking........On }ã{$Q+} { Overflow Checking.....On }ã{$ELSE}ã{$B-} { Boolean Evaluation....Short Circuit }ã{$D-} { Debugging Info........Off }ã{$L-} { Line Numbers..........Off }ã{$Y-} { Symbol Information....Off }ã{$R-} { Range Checking........Off }ã{$S-} { Stack Checking........Off }ã{$Q-} { Overflow Checking.....On }ã{$ENDIF}ãã{ãProgram Memory Requirementsã}ã{$M 32000,0,0} { Stack Size............32000 Heap.....0 }ãã.----------------------------------------------------.ã| Colin Buckley |ã| Toronto, Ontario, Canada |ã| InterNet: [email protected] |ã| |ã| So Eager to Play, So Relunctant to Admit it... |ã`----------------------------------------------------'ãã---ã þ RoseReader 2.10á P003288 Entered at [ROSE]ã * Rose Media, Toronto, Canada : 416-733-2285ã * PostLink(tm) v1.04 ROSE (#1047) : RelayNet(tm)ãã 19 05-31-9308:05ALL FLOOR NAAIJKENS RANDOM NUMBER GENERATOR IMPORT 21 oQc ==============================================================================ã BBS: The Sand Box BBS - SourceNet Central HUBã To: JUD MCCRANIE Date: 12-17Ä92 (16:42)ãFrom: TREVOR CARLSEN Number: 531 [87] FD-PascalãSubj: BP 7 DIFFERENCE Status: Publicã------------------------------------------------------------------------------ã JM> The behavior of RANDOM (with RandSeed set) is different inã JM> BP7 (and presumably TP7) from that in TP 5.5. (I don't knowã JM> how TP 6 compares since I burned it off my disk).ãã JM> RandSeed := 123;ã JM> for i := 1 to 8 do writeln( random( 1000));ãã JM> TP 5.5: 343 282 986 996 781 855 343 32ã JM> BP 7.0: 859 80 869 854 317 257 20 46ãã JM> ...both are consistant, but they are different sequences.ã JM> This can have some dire consequences. ...ããIt certainly could if you did not know about it and unfortunately I canãfind no reference to the changes in the documentation. (Richard Nelson?)ããHere is a fix (supplied to me via Netmail courtesy Joe Lamoine - thanks Joe).ãã>Quote........ããI posted a message on Compuserve last nite and got the followingãunit in a response. It seems to work fine!ããã{ * Turbo Pascal Runtime Library Version 6.0 * ;ã * Random Number Generator * ;ã * * ;ã * Copyright (C) 1988,92 Borland International * }ãã unit TP6Rand;ãã interfaceãã function Random(Max: Integer): Integer;ãã implementationãã constã { Scaling constant}ã ConstM31 = Longint(-31);ã { Multiplication factor}ã Factor: Word = $8405;ããã function NextRand: Longint; assembler;ã { Compute next random numberã New := 8088405H * Old + 1ã Out DX:AX = Next random numberã }ã asmã MOV AX,RandSeed.Word[0]ã MOV BX,RandSeed.Word[2]ã MOV CX,AXã MUL Factor.Word[0] { New = Old.w0 * 8405H }ã SHL CX,1 { New.w2 += Old.w0 * 808H }ã SHL CX,1ã SHL CX,1ã ADD CH,CLã ADD DX,CXã ADD DX,BX { New.w2 += Old.w2 * 8405H }ã SHL BX,1ã SHL BX,1ã ADD DX,BXã ADD DH,BLã MOV CL,5ã SHL BX,CLã ADD DH,BLã ADD AX,1 { New += 1 }ã ADC DX,0ã MOV RandSeed.Word[0],AXã MOV RandSeed.Word[2],DXã end;ããfunction Random(Max: Integer): Integer; assembler;ã asmã CALL NextRandã XOR AX,AXã MOV BX,Max.Word[0]ã OR BX,BXã JE @@1ã XCHG AX,DXã DIV BXã XCHG AX,DXã @@1:ã end;ããend.ãã>End of quote.ãããTeeCeeããã--- TC-ED v2.01ã * Origin: The Pilbara's Pascal Centre (+61 91 732930) (3:690/644)ã 20 06-22-9309:24ALL SWAG SUPPORT TEAM Hi Resolution Timer IMPORT 20 o@B UNIT Timer;ãã{ TIMER - Fine resolution timer functions }ããINTERFACEãUSES Crt,Dos;ãCONSTã TixSec = 18.20648193;ã TixMin = TixSec * 60.0;ã TixHour = TixMin * 60.0;ã TixDay = TixHour * 24.0;ãTYPEã DiffType = String[16];ãVARã tGet : Longint ABSOLUTE $0040:$006C;ãFUNCTION tStart: Longint;ãFUNCTION tDiff(StartTime,EndTime: Longint) : Real;ãFUNCTION tFormat(T1,T2:Longint): DiffType;ãPROCEDURE GetTime(H,M,S,S100:Word);ããIMPLEMENTATIONããVARã TimeDiff : DiffType;ãã{ tStart - wait for a new tick, and return theã tick number to the caller. The wait allowsã us to be sure the user gets a start at theã beginning of the second. }ããFUNCTION tStart: Longint;ãVARã StartTime : Longint;ãBEGINã StartTime := tGet;ã WHILE StartTime = tGet DO;ã tStart := tGetãEND;ãã{ tDiff - compute the difference between twoã timepoints (in seconds). }ããFUNCTION tDiff(StartTime,EndTime: Longint) : Real;ãBEGINã tDiff := (EndTime-StartTime)/TixSec;ãEND;ããPROCEDURE GetTime(H,M,S,S100:Word);ãVARã Regs : Registers;ãBEGINã Regs.AH := $2C;ã MsDos(Regs);ã H := Regs.CH;ã M := Regs.CL;ã S := Regs.DH;ã S100 := Regs.DLãEND;ãã{ tFormat - given two times, return a pointerã to a (static) string that is the differenceã in the times, formatted HH:MM:SS }ããFUNCTION tFormat(T1,T2:Longint): DiffType;ããFUNCTION rMod(P1,P2: Real): Real;ãBEGINã rMod := Frac(P1/P2) * P2ãEND;ããVARã Temp : Real;ã tStr : String;ã TempStr : String[2];ã TimeValue : ARRAY [1..4] OF Longint;ã I : Integer;ãBEGINã Temp := t2-t1; { Time diff. }ã {Adj midnight crossover}ã IF Temp < 0 THENã Temp := Temp + TixDay;ã TimeValue[1] := Trunc(Temp/TixHour); {hours}ã Temp := rMod(Temp,TixHour);ã TimeValue[2] := Trunc(Temp/TixMin); {minutes}ã Temp := rMod(Temp,TixMin);ã TimeValue[3] := Trunc(Temp/TixSec); {seconds}ã Temp := rMod(Temp,TixSec); {milliseconds}ã TimeValue[4] := Trunc(Temp*100.0/TixSec+0.5);ã STR(TimeValue[1]:2,tStr);ã IF tStr[1] = ' ' THEN tStr[1] := '0';ã FOR I := 2 TO 3 DOã BEGINã STR(TimeValue[I]:2,TempStr);ã IF TempStr[1]=' ' THENã TempStr[1]:='0';ã tStr := tStr + ':'+ TempStrã END;ã STR(TimeValue[4]:2,TempStr);ã IF TempStr[1]=' ' THEN TempStr[1]:='0';ã tStr := tStr + '.' + TempStr;ã tFormat := tStrãEND;ããEND.ã 21 07-16-9306:11ALL SWAG SUPPORT TEAM A source code mangler IMPORT 43 o {ãHere is a VERY simple source-code mangler that I just made. It simply:ãã1) Removes whitespace,ã2) Removes comments (but not Compiler-directives!),ã3) Makes everything upper-Case.ã4) Make lines max. 127 Chars wide (max. For Turbo Pascal),ã5) Doesn't mess up literal Strings :-)ããI don't imagine that this is anything Near perfect - but it's better thanãnothing...ãã}ããProgram Mangler;ããConstã Alpha : Set of Char = ['a'..'z', 'A'..'Z', '0'..'9'];ããVarã F, F2 : Text;ã R, S : String;ã X : Byte;ã InString : Boolean;ããFunction NumChar(C : Char; S : String; Max : Byte) : Byte;ãVarã N, Y : Byte;ãbeginã N := 0;ã For Y := 1 to Max doã if S[Y] = C then Inc(N);ã NumChar := N;ãend;ããFunction TrimF(T : String) : String;ãVarã T2 : String;ãbeginã T2 := T;ã While (Length(T2) > 0) and (T2[1] = ' ') doã Delete(T2, 1, 1);ã TrimF := T2;ãend;ããFunction Trim(T : String) : String;ãVarã T2 : String;ãbeginã T2 := TrimF(T);ã While (Length(T2) > 0) and (T2[Length(T2)] = ' ') doã Delete(T2, Length(T2), 1);ã Trim := T2;ãend;ããProcedure StripComments(Var T : String);ãVarã Y : Byte;ã Rem : Boolean;ãbeginã Rem := True;ã if Pos('(*', T) > 0 thenã beginã For Y := Pos('(*', T) to Pos('*)', T) doã if (T[Y] = '$') or (T[Y] = '''') thenã Rem := False;ã if (Rem) and (not Odd(NumChar('''', T, Pos('(*', T)))) thenã Delete(T, Pos('(*', T), Pos('*)', T)+2-Pos('(*', T));ã end;ã if Pos('{', T) > 0 thenã beginã For Y := Pos('{', T) to Pos('}', T) doã if (T[Y] = '$') or (T[Y] = '''') thenã Rem := False;ã if (Rem) and (not Odd(NumChar('''', T, Pos('(*', T)))) thenã Delete(T, Pos('{', T), Pos('}', T)+1-Pos('{', T));ã end;ãend;ããbeginã ReadLn(S);ã Assign(F, S);ã Reset(F);ã ReadLn(S);ã Assign(F2, S);ã ReWrite(F2);ã R := '';ã S := '';ãã While not EoF(F) doã beginã ReadLn(F, R);ã StripComments(R);ã R := Trim(R);ã X := 1;ã While X <= Length(R) doã beginã InString := (R[X] = '''') xor InString;ã if not InString thenã beginã if R[X] = #9 thenã R[X] := ' ';ã if ((R[X] = ' ') and (R[X+1] = ' ')) thenã beginã Delete(R, X, 1);ã if X > 1 thenã Dec(X);ã end;ã if ((R[X] = ' ') and not(R[X+1] in Alpha)) thenã Delete(R, X, 1);ã if ((R[X+1] = ' ') and not(R[X] in Alpha)) thenã Delete(R, X+1, 1);ã R[X] := UpCase(R[X]);ã end;ã Inc(X);ã end;ã if (Length(R) > 0) and (R[Length(R)] <> ';') thenã R := R+' ';ã if Length(R)+Length(S) <= 127 thenã S := TrimF(S+R)ã elseã beginã WriteLn(F2, Trim(S));ã S := TrimF(R);ã end;ã end;ãã WriteLn(F2, S);ã Close(F);ã Close(F2);ãend.ã{ã > 1) Remove whitespace.ãJust removes indentation now.ã > 2) Put lines together (max. length approx. 120 Chars).ãThis is going to be one of the harder parts.ã > 3) Make everything lower-Case (or upper-Case).ãNo need.. see 4.ã4. Convert all Types, Consts, and VarS to an encypted name, like so:ã IIl0lll1O0lI1ã5. Convert all Procedures, and Functions like #4ã6. On Objects, Convert all "data" fields. Leave alone all others except Forãthe "ConstRUCtoR" and on that, only check to see if any Types are being used.ãConstructors are the only ones that can change from the ancestor.ã7. on Records, When Typed like this:ãaRec.Name:='Rob Green'; check to see if arec is in the list, if not, skip.ãif like this:ã With arec doã name:='Rob Green'; do the same as above, but check For begin and end.ã8. Leave externals alone.ã9. Also mangle the Includes.ã10. Leave Any Interface part alone, and only work With the Implementation.ãThis is what my mangler currently does.(all except For #7 and #10, havent gotãthat Far yet.) Any ways it works pretty good. im happy With the results iãam getting With it. It makes it "VERY" hard to read. The only thing i seeãhaving trouble With down the line, is the "Compressing" of mulitiple lines.ããAnyways, heres a small Program, and then what PAM(Pascal automatic mangler)ãdid to it:ã}ããProgram test;ããTypeã pstr30 = ^str30;ã str30 = String[30];ããVarã b : Byte;ã s : pstr30;ããFunction hex(b : Byte) : String;ãConstã Digits : Array [0..15] of Char = '0123456789ABCDEF';ãVarã s:String;ãbeginã s:='';ã s[0] := #2;ã s[1] := Digits [b shr 4];ã s[2] := Digits [b and $F];ã hex:=s;ãend;ããbeginã new(s);ã s^:='Hello world';ã Writeln(s^);ã Writeln('Enter a Byte to convert to hex:');ã readln(b);ã s^:=hex(b);ã Writeln('Byte :',b,' = $',s^);ã dispose(s);ãend.ãããProgram test;ãTypeã IO1II0IO00O = ^II0lOl1011I;ã II0lOl1011I = String[30];ãVarã III0O1ll10l:Byte;ã I11110I11Il0:IO1II0IO00O;ããFunction Il00O011IO0I(III0O1ll10l:Byte):String;ãConstã Illl1OOOO0I : Array [0..15] of Char = '0123456789ABCDEF';ãVarã I11110I11Il0:String;ãbeginã I11110I11Il0:='';ã I11110I11Il0[0] := #2;ã I11110I11Il0[1] := Illl1OOOO0I [III0O1ll10l shr 4];ã I11110I11Il0[2] := Illl1OOOO0I [III0O1ll10l and $F];ã Il00O011IO0I:=I11110I11Il0;ãend;ãbeginã new(I11110I11Il0);ã I11110I11Il0^:='Hello world';ã Writeln(I11110I11Il0^);ã Writeln('Enter a Byte to convert to hex:');ã readln(III0O1ll10l);ã I11110I11Il0^:=Il00O011IO0I(III0O1ll10l);ã Writeln('Byte :',III0O1ll10l,' = $',I11110I11Il0^);ã dispose(I11110I11Il0);ãend.ãã 22 07-16-9306:13ALL KENT BRIGGS Randmom Number Function IMPORT 16 oQc ===========================================================================ã BBS: Canada Remote SystemsãDate: 06-18-93 (23:27) Number: 26893ãFrom: KENT BRIGGS Refer#: NONEã To: BRIAN PAPE Recvd: NO ãSubj: RANDOM NUMBERS Conf: (1221) F-PASCALã---------------------------------------------------------------------------ã -=> Quoting Brian Pape to Erik Johnson <=-ãã BP> Please- I *am* looking for the source code to a decent random numberã BP> generator so that I'm not dependant on Borland.ãã Brian, Borland did change their random:word function when they releasedã 7.0. However the random:real function, the randomize procedure, and theirã method of updating randseed remain the same as ver 6.0. Using DJ Murdoch'sã CycleRandseed procedure and reverse engineering TP6's and TP7's Randomã functions, I came up with the following routines:ããconst rseed: longint = 0;ããprocedure randomize67; {TP 6.0 & 7.0 seed generator}ãbeginã reg.ah:=$2c;ã msdos(reg); {get time: ch=hour,cl=min,dh=sec,dl=sec/100}ã rseed:=reg.dx;ã rseed:=(rseed shl 16) or reg.cx;ãend;ããfunction rand_word6(x: word): word; {TP 6.0 RNG: word}ãbeginã rseed:=rseed*134775813+1;ã rand_word6:=(rseed shr 16) mod x;ãend;ããfunction rand_word7(x: word): word; {TP 7.0 RNG: word}ãbeginã rseed:=rseed*134775813+1;ã rand_word7:=((rseed shr 16)*x+((rseed and $ffff)*x shr 16)) shr 16;ãend;ããfunction rand_real67: real; {TP 6.0 & 7.0 RNG: real}ãbeginã rseed:=rseed*134775813+1;ã if rseed<0 then rand_real67:=rseed/4294967296.0+1.0 elseã rand_real67:=rseed/4294967296.0;ãend;ããIf anyone can improve on these please post some code here, thanks.ãã___ Blue Wave/QWK v2.12ã--- Renegade v06-11 Betaãã * Origin: Snipe's Castle BBS, Waco TX (817)-757-0169 (1:388/26)ã 23 08-18-9312:20ALL JOSE ALMEIDA Get the active code page IMPORT 20 o2 { Gets the active (set by user) and system (at boot byte) code page.ã Part of the Heartware Toolkit v2.00 (HTelse.PAS) for Turbo Pascal.ã Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.ã I can also be reached at RIME network, site ->TIB or #5314.ã Feel completely free to use this source code in any way you want, and, ifã you do, please don't forget to mention my name, and, give me and Swag theã proper credits. }ããPROCEDURE Get_Code_Page(var Active_CP : word;ã var System_CP : word;ã var Error_Code : byte);ã{ DESCRIPTION:ã Gets the active (set by user) and system (at boot byte) code page.ã SAMPLE CALL:ã Get_Code_Page(Active_CP,Default_CP,Error_Code);ã RETURNS:ã Active : active code page set by userã System : system code page at boot timeã Error_Codeã 0 : no errorã else : see The Programmers PC Source Book 3.191ã NOTES:ã Applies to all versions beginning with v3.3.ã See Get_Code_Page_Text() in order to get string text. }ããvarã HTregs : registers;ããBEGIN { Get_Code_Page }ã HTregs.AX := $6601;ã MsDos(HTregs);ã if HTregs.Flags and FCarry <> 0 thenã beginã Active_CP := $FFFF; { on error set to $FFFF }ã System_CP := $FFFF; { on error set to $FFFF }ã Error_Code := HTregs.AL;ã endã elseã beginã Active_CP := HTregs.BX;ã System_CP := HTregs.DX;ã Error_Code := 0;ã end;ãEND; { Get_Code_Page }ããããFUNCTION Get_Code_Page_Text(CP : word) : String14;ãã{ DESCRIPTION:ã Gets the current active code page in string form.ã SAMPLE CALL:ã St := Get_Code_Page_Text(860);ã RETURNS:ã e.g.: 'Portugal'ã NOTES:ã None. }ããBEGIN { Get_Code_Page_Text }ã case CP ofã 437 : Get_Code_Page_Text := 'USA English';ã 850 : Get_Code_Page_Text := 'Multilingual';ã 852 : Get_Code_Page_Text := 'CZ/SL/HU/PL/YU';ã { CZ and SL = Czechoslovakia (Czech & Slovak) }ã { HU = Hungary }ã { PL = Poland }ã { YU = Yugoslavia }ã 854 : Get_Code_Page_Text := 'Spain';ã 860 : Get_Code_Page_Text := 'Portugal';ã 863 : Get_Code_Page_Text := 'Canada-French';ã 865 : Get_Code_Page_Text := 'Norway/Denmark';ã elseã Get_Code_Page_Text := 'Unknown';ã end;ãEND; { Get_Code_Page_Text }ã 24 08-18-9312:27ALL JOSE ALMEIDA Intra-App Comm Area IMPORT 15 oå { Gets or puts information in the Intra-Application Communications Area (ICA).ã Part of the Heartware Toolkit v2.00 (HTmemory.PAS) for Turbo Pascal.ã Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.ã I can also be reached at RIME network, site ->TIB or #5314.ã Feel completely free to use this source code in any way you want, and, ifã you do, please don't forget to mention my name, and, give me and Swag theã proper credits. }ããPROCEDURE ICA(GetPut : boolean;ã var SourceDest);ã{ DESCRIPTION:ã Gets or puts information in the Intra-Application Communications Area (ICA).ã SAMPLE CALL:ã ICA(True,MyVar);ã orã ICA(False,MyVar);ã RETURNS:ã See notes (bellow).ã NOTES:ã These sixteen bytes, called the Intra-Application Communications Areaã (ICA) can be used by any program for any purpose, Usually it is usedã to pass data betwenn two or more programs. Not many programs use thisã area. If you wish to use this area, make sure checksums and signaturesã are used to insure the reliability of your data, since another programã may also decide to use this area.ã [in The Assembly Language Database, Peter Norton]ã The incomming SourceDir variable may be of any type.ã Nevertheless, the size of that variable MUST be at least 16 bytes long,ã or unpredictable results may occur...ã The programer before changing this area contents, should keep itsã contents in a variable for later restore. It is not a very good ideiaã to not restore the contents before the program end, because thatã area may being used by another program. }ããBEGIN { ICA }ã if GetPut thenã Move(Mem[$0000:$04F0],SourceDest,16)ã elseã Move(SourceDest,Mem[$0000:$04F0],16)ãEND; { ICA }ã 25 08-18-9312:28ALL JOSE ALMEIDA Get Print Screen Status IMPORT 8 o± { Gets the status of the last or current Print Screen operation.ã Part of the Heartware Toolkit v2.00 (HTparal.PAS) for Turbo Pascal.ã Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.ã I can also be reached at RIME network, site ->TIB or #5314.ã Feel completely free to use this source code in any way you want, and, ifã you do, please don't forget to mention my name, and, give me and Swag theã proper credits. }ããFUNCTION PrtSc_Status : byte;ã{ DESCRIPTION:ã Gets the status of the last or current Print Screen operation.ã SAMPLE CALL:ã NB := PrtSc_Status;ã RETURNS:ã 00h : Print Screen completeã 01h : Print Screen currently in progressã FFh : Error occurred during Print Screen }ããBEGIN { PrtSc_Status }ã PrtSc_Status := Mem[$0000:$0500];ãEND; { PrtSc_Status }ã 26 08-27-9320:00ALL SWAG SUPPORT TEAM Finding Anagrams IMPORT 47 o«Ç {$A+,B+,D+,E-,F+,G+,I+,L+,N-,O+,P+,Q+,R+,S+,T+,V-,X+,Y+}ã{$M 65520,100000,655360}ã{ãProgram compiled and tested With BP 7.0ããWARNING since this Program is not using the fastest algorithm toãfind it's Anagrams, long Delays can be expected For largeãinput-Strings.ããTest have shown the following results:ãã Length of Input Number of anagrams foundãã 2 2ã 3 6ã 4 24ã 5 120ã 6 720ã 7 5040ããAs can plainly be seen from this, the number of Anagrams For aãString of length N is a direct Function of the number of AnagramsãFor a String of N-1. In fact the result is f(N) = N * f(N-1).ããYou might have recognised the infamous FACTORIAL Function!!!ããTypeã MyType = LongInt;ããFunction NumberOfAnagrams(Var InputLen : MyType) : MyType;ãã Varã Temp : MyType;ãã beginã Temp := InputLen;ã if Temp >1 thenã beginã Temp := Temp - 1;ã NumberOfAnagrams := InputLen * NumberOfAnagrams(Temp);ã end elseã NumberOfAnagrams := InputLen;ã end;ããThe above Function has been tested and found to work up to an inputãlength of 12. After that, Real numbers must be used. As a side noteãthe Maximum value computable was 1754 With MyType defined asãExtended and Numeric-Coprocessor enabled of course. Oh and BTW, theãparameter is passed as a Var so that the Stack doesn't blow up whenãyou use Extended Type!!!! As a result, you can't pass N-1 to theãFunction. You have to STORE N-1 in a Var and pass that as parameter.ãThe net effect is that With Numeric Copro enabled, at 1754 it blowsãup because of a MATH OVERFLOW, not a STACK OVERFLOW!!!ããBased on these findings, I assume the possible anagrams can beãcomputed a lot faster simply by Realising that the possible AnagramsãFor an input length of (N) can be found by finding all anagrams forãan input Length of (N-1) and inserting the additional letter in eachã(N) positions in those Strings. Since this can not be doneãrecursively in memory, the obvious solution would be to to outputãthe anagrams strating With the first 4 or 5 caracters to a File,ãbecause those can be found quickly enough, and then to read in eachãString and apply the following caracters to each and Repeat thisãprocess Until the final File is produced.ããHere is an example:ãã Anagrams For ABCDãã Output Anagrams For AB to Fileãã Giving AB and BAãã read that in and apply the next letter in all possible positionsãã Givingã abCã aCbã Cabã &ã baCã bCaã Cbaãã Now Apply the D to this and getãã abcDã abDcã aDbcã Dabcã &ãã acbDã acDbã aDcbã Dacbãã Etc... YOU GET THE POINT!!!ããBTW Expect LARGE Files if you become too enthousiastic With this!!!ãã An Input of just 20 caracters long will generate a File ofãã 2,432,902,008,176,640,000 Anagramsã That'sã 2.4 Quintillion Anagramsãã Remember that each of those are 20 caracters long,ã add Carriage-return and line-feeds and you've got yourself aã HUGE File ;-)ãã In fact just a 10 Caracter input length will generate 3.6 Millionã Anagrams from a 10 Caracter input-String. Again add Cr-LFs andã you've got yourself a 43.5 MEGAByte File!!!!!! but consider youã are generating it from the previous File which comes to 3.5 MEGã For an Input Length of 9 and you've got yourself 45 MEG of DISK inã use For this job.ãã}ãUsesã Strings, Crt;ããConstã MaxAnagram = 1000;ããTypeã AnagramArray = Array[0..MaxAnagram] of Word;ã AnagramStr = Array[0..MaxAnagram] of Char;ããVarã Target : AnagramStr;ã Size : Word;ã Specimen : AnagramArray;ã Index : Word;ã AnagramCount : LongInt;ããProcedure working;ãConstã CurrentCursor : Byte = 0;ã CursorArray : Array[0..3] of Char = '|/-\';ãbeginã CurrentCursor := Succ(CurrentCursor) mod 4;ã Write(CursorArray[CurrentCursor], #13);ãend;ããProcedure OutPutAnagram(Target : AnagramStr;ã Var Specimen : AnagramArray; Size : Word);ãVarã Index : Word;ãbeginã For Index := 0 to (Size - 1) doã Write(Target[Specimen[Index]]);ã Writeln;ãend;ããFunction IsAnagram(Var Specimen : AnagramArray; Size : Word) : Boolean;ãVarã Index1,ã Index2 : Word;ã Valid : Boolean;ãbeginã Valid := True;ã Index1 := 0;ã While (Index1= Size);ã Until Carry and (Index >= Size);ãend;ããbeginã ClrScr;ã Write('Enter anagram Target: ');ã readln(Target);ã Writeln;ã AnagramCount := 0;ã Size := Strlen(Target);ã For Index := 0 to MaxAnagram doã Specimen[Index] := 0;ã For Index := 0 to Size - 1 doã Specimen[Index] := Size - Index - 1;ã FindAnagrams(Target, Specimen, Size);ã Writeln;ã Writeln(AnagramCount, ' Anagrams found With Source ', Target);ãend.ã 27 08-27-9320:01ALL MARK OUELLET Fast Anagrams IMPORT 20 oÝö {$A+,B+,D+,E-,F+,G+,I+,L+,N-,O+,P+,Q+,R+,S+,T+,V-,X+,Y+}ã{$M 65520,100000,655360}ã{ã Copyright 1993 Mark Ouellet. All rights reserved.ãã May be freely distributed and incorporated in your own code, in partã or in it's entirety as long as due credit is given to it's authorãã All I ask is that you state my name if you use ALL or PART of it inã your own code.ã}ããProgram FastAnagrams;ããUsesã Crt;ããTypeã StrPointer = ^String;ã NodePtr = ^Node;ã Node = Recordã Anagram : StrPointer;ã Next : NodePtr;ã end;ããVarã OldAnagrams : NodePtr;ã NewAnagrams : NodePtr;ã OldCursor : NodePtr;ã NewCursor : NodePtr;ã InputStr : String;ããProcedure GetInput;ãbeginã ClrScr;ã Write('Input your String: ');ã readln(InputStr);ãend;ããProcedure FindAnagrams;ããVarã OldIndex : Word;ã NewIndex : Word;ããbeginã OldAnagrams := NIL;ã OldCursor := NIL;ã NewAnagrams := NIL;ã NewCursor := NIL;ãã New(OldCursor);ã OldCursor^.Next := OldAnagrams;ã GetMem(OldCursor^.Anagram, 2);ã OldCursor^.Anagram^ := Copy(InputStr, 1, 1);ã OldAnagrams := OldCursor;ãã For OldIndex := 2 to Ord(InputStr[0]) doã beginã OldCursor := OldAnagrams;ã While OldCursor <> NIL doã beginã For NewIndex := 1 to Ord(OldCursor^.Anagram^[0])+1 doã beginã New(NewCursor);ã NewCursor^.Next := NewAnagrams;ã getmem(NewCursor^.Anagram, sizeof(OldCursor^.Anagram^)+1);ã NewCursor^.Anagram^ := OldCursor^.Anagram^;ã Insert(Copy(InputStr, OldIndex, 1),ã NewCursor^.Anagram^, NewIndex);ã NewAnagrams := NewCursor;ã end;ã OldCursor := OldCursor^.Next;ã FreeMem(OldAnagrams^.Anagram, Ord(OldAnagrams^.Anagram^[0])+1);ã OldAnagrams^.Anagram := nil;ã Dispose(OldAnagrams);ã OldAnagrams := OldCursor;ã end;ã OldAnagrams := NewAnagrams;ã OldCursor := OldAnagrams;ã NewAnagrams := NIL;ã NewCursor := NIL;ã end;ãend;ããProcedure OutputAnagrams;ãVarã Count : Word;ãbeginã Count := 0;ã OldCursor := OldAnagrams;ã While OldCursor <> NIL doã beginã OldCursor := OldCursor^.Next;ã Writeln(OldAnagrams^.Anagram^);ã FreeMem(OldAnagrams^.Anagram, sizeof(OldAnagrams^.Anagram^));ã dispose(OldAnagrams);ã OldAnagrams := OldCursor;ã Inc(Count);ã end;ã Writeln;ã Writeln(Count, ' Anagrams found.');ãend;ããbeginã GetInput;ã Writeln;ã Writeln(MaxAvail, ' Available memory.');ã Writeln;ã FindAnagrams;ã OutputAnagrams;ãend.ã 28 08-27-9320:35ALL DAVID JURGENS dBase II File Structure IMPORT 17 om] HelpPC 2.0 PC Programmers Referenceã Copyright (c) 1990 David Jurgensãã dBASE - File Header Structure (dBASE II)ãã Offset Size Descriptionãã 00 byte dBASE version number 02h=dBASE IIã 01 word number of data records in fileã 03 byte month of last updateã 04 byte day of last updateã 05 byte year of last updateã 06 word size of each data recordã 08 512bytes field descriptors (see below)ã 520 byte 0Dh if all 32 field descriptors used; otherwise 00hãã - dBASE II file header has a fixed size of 521 bytesããã DBASE - File header structure (DBASE III)ãã Offset Size Descriptionãã 00 byte dBASE vers num 03h=dBASE III w/o .DBTã 83h=dBASE III w .DBTã 01 byte year of last updateã 02 byte month of last updateã 03 byte day of last updateã 04 dword long int number of data records in fileã 08 word header structure lengthã 10 word data record lengthã 12 20bytes version 1.0 reserved data spaceã 32-n 32bytes ea. field descriptors (see below)ã n+1 byte 0dH field terminator.ããã - unlike dBASE II, dBASE III has a variable length headerããã dBASE - Field Descriptorsãã dBASE II Field Descriptors (header contains 32 FDs)ãã Offset Size Descriptionãã 00 11bytes null terminated field name string, 0Dh as firstã byte indicates end of FDsã 11 byte data type, Char/Num/Logical (C,N,L)ã 12 byte field lengthã 13 word field data address, (set in memory)ã 15 byte number of decimal placesããã dBASE III Field Descriptors (FD count varies):ãã Offset Size Descriptionãã 00 11bytes null terminated field name stringã 11 byte data type, Char/Num/Logical/Date/Memoã 12 dword long int field data address, (set in memory)ã 16 byte field lengthã 17 byte number of decimal placesã 18 14bytes version 1.00 reserved data areaãã 29 08-27-9320:38ALL GORDON TACKETT Device Driver in TP IMPORT 8 oÐ {ãGORDON TACKETTããIn version 7 of TP/BP you can write a device driver But it is tricky! Theãfollowing code is not fully tested but seems to work. After looking at someãdisassembly listings I added the patch file section. Use or abuse at your ownãrisk :-)ã}ããProgram TestDriver;ããProcedure Dev_Strategy; Forward;ãProcedure Dev_Int; Forward;ããProcedure DeviceDriverHeader;ãbeginã Inline(ã $FFFF/ã $FFFF/ã $2000/ã $0000/ã $0000/ã $FFFF/$FFFF/$FFFF/$FFFF/0);ãEnd;ããProcedure Dev_Strategy;ãBeginãEnd;ããProcedure Dev_Int;ãBeginãEnd;ããVarã F : File;ããBeginã If ParamCount = 999 Thenã DeviceDriverHeaderã elseã Beginã {patch driver}ã movemem(devicedriverheader, DeviceDriverHeader + 3, 20);ã Assign(F, ParamStr(0));ã Reset(F, 1);ã BlockWrite(F, DeviceDriverHeader, 20);ã Close(F);ã End;ãEnd.ãã 30 08-27-9320:38ALL D.J. MURDOCK Another Device in TP IMPORT 42 o&à {ãI've written a simple device driver in TP, and it works. From some things I'veãheard, it won't work in all versions of DOS (it's an .EXE format device driver,ãnot a .BIN format one). There are tons of restrictions on what you can do inãit - DOS isn't reentrant, and the TP system library isn't designed to do thingsãwhile DOS is active, so I don't even let it get initialized, etc., etc.ããIt's still a bit of a mess, but here it is, for your enjoyment and edification:ã a character device driver that keeps a buffer of 255 characters, calledãTPDEVICE.ããTo try it out, compile it (you'll need OPro or TPro; sorry, but stack swappingãis essential, and I wouldn't want to try to write code to do it myself), put itãinto your CONFIG.SYS (on a floppy disk, please!) asãã device=tpdev.exeããand then reboot. Hopefully you won't crash, but if you do, you'll have toãreboot from a different disk and remove it from CONFIG.SYS.ããThen you can tryãã COPY TPDEVICE CONããto see the initialization message, andãã ECHO This is a line for the buffer >TPDEVICEããto replace it with a new one.ã}ã{ DOS character device driver written entirely in TP 6 }ãã{ Written by D.J. Murdoch for the public domain, May 1991 }ãã{$S-,F-} { Stack checking wouldn't work here, and we assume near calls }ã{$M $1000,0,0} { We can't use the heap and don't use the stack. Thisã setting doesn't really matter though, since you normallyã won't run TPDEV }ããprogram tpdev;ããusesã opint; { OPro interrupt services, needed for stack switching }ããprocedure strategy_routine(bp:word); interrupt; forward;ãprocedure interrupt_routine(bp:word); interrupt; forward;ããprocedure header; assembler;ã{ Here's the trick: an assembler routine in the main program, guaranteed toã be linked first in the .EXE file!!}ãasmã dd $FFFFFFFF { next driver }ã dw $8000 { attributes of simple character device }ã dw offset strategy_routineã dw offset interrupt_routineã db 'TPDEVICE'ãend;ããconstã stDone = $100;ã stBusy = $200;ãã cmInit = 0;ã cmInput = 4;ã cmInput_no_wait = 5;ã cmInput_status = 6;ã cmInput_flush = 7;ã cmOutput = 8;ã cmOutput_Verify = 9;ã cmOutput_status = 10;ã cmOutput_flush = 11;ããtypeã request_header = recordã request_length : byte;ã subunit : byte;ã command_code : byte;ã status : word;ã reserved : array[1..8] of byte;ã case byte ofã cmInit : (num_units : byte;ã first_free : pointer;ã args : ^char;ã drive_num : byte;);ã cmInput : { also used for output }ã (media_descriptor : byte;ã buffer : pointer;ã byte_count : word);ã cmInput_no_wait : (next_char : char);ã end;ããvarã local_stack : array[1..4000] of byte;ã end_of_stack : byte;ã request : ^request_header;ã line : string;ããprocedure handler(var regs : intregisters);ã{ This routine is called by the strategy routine, and handles all requests.ã The data segment is okay, and we're running on the local_stack so we've gotã plenty of space, but remember:ã ****** The initialization code for SYSTEM and all other units hasn'tã ever been called!! ******** }ãbeginã with request^ doã beginã case command_code ofãã cmInit :ã beginã { Last thing in the data segment in TP6 - No heap!!}ã first_free := ptr(dseg, ofs(saveint75) + 4);ã status := stDone;ã line := 'TPDRIVER successfully initialized.';ã end;ãã cmInput :ã beginã if byte_count > length(line) thenã byte_count := length(line);ã move(line[1], buffer^, byte_count);ã line := copy(line, byte_count + 1, 255);ã status := stDone;ã end;ãã cmInput_no_wait :ã beginã if length(line) > 0 thenã beginã next_char := line[1];ã status := stDone;ã endã elseã status := stBusy;ã end;ãã cmInput_Status,ã cmOutput_Status,ã cmInput_Flush,ã cmOutput_Flush : status := stDone;ãã cmOutput,ã cmOutput_Verify :ã beginã if byte_count + length(line) > 255 thenã byte_count := 255 - length(line);ã move(buffer^, line[length(line) + 1], byte_count);ã line[0] := char(byte(byte_count + length(line)));ã status := stDone;ã end;ã end;ã end;ãend;ããprocedure RetFar; assembler;ã{ Replacement for the IRET code that ends the interrupt routines below }ãasmã mov sp,bpã pop bpã pop esã pop dsã pop diã pop siã pop dxã pop cxã pop bxã pop axã retfãend;ããprocedure strategy_routine(bp : word);ãvarã regs : intregisters absolute bp;ãbeginã with regs doã request := ptr(es, bx);ã RetFar;ãend;ããprocedure interrupt_routine(bp : word);ãvarã regs : intregisters absolute bp;ãbeginã SwapStackandCallNear(Ofs(handler), @end_of_stack, regs);ã RetFar;ãend;ããbeginã writeln('TPDEVICE - DOS device driver written *entirely* in Turbo Pascal.');ã writeln('Install using DEVICE=TPDEV.EXE in CONFIG.SYS.');ã request := @header; { Need a reference to pull in the header. }ãend.ã 31 08-27-9320:55ALL JACK MOFFITT File at end of EXE IMPORT 25 o {ãJACK MOFFITTãã>Okay, how about this: If I wanted to attach it to the back of an EXE, Iã>COPY /B it. Now, in the source code, how do I find the picture and setã>everything up? I mean do you LoadGif (Ofs,Seg) or something? That's whatã>I mean, and I'm sorry to put you through this.ããOk.. here we go.. everyone seems to be asking this, so i'll just postãsome source. Granted this is not a COMPLETE program, just an example onãhow to read the header, and get a pointer to the GIF.ã}ãã(* This code originally by Scott Johnson, I revised it later *)ããfunction GetSize(N : byte) : word;ãfunction GetData(N : byte) : pointer;ãfunction GetDataCount : byte;ããimplementationããusesã Dos;ããtypeã DataRec = recordã Size : word;ã Loc : longint;ã end;ã DataArray = array [1..255] of DataRec;ã DataArrayPtr = ^DataArray;ãã ExeDataRec = recordã ActSize : word;ã end;ãããvarã ExeFile : file;ã DataCount : byte; { count of data records }ã Data : DataArrayPtr;ããprocedure OpenExe;ãbeginã assign(ExeFile, ParamStr(0));ã reset(ExeFile, 1);ãend;ããprocedure CloseExe;ãbeginã Close(ExeFile);ãend;ããprocedure InitExe;ãvarã ExeHdr : recordã M, Z : char;ã Len : word;ã Pages : word;ã end;ã ExeLoc : longint;ã I : byte;ã ExeData : ExeDataRec;ãbeginã OpenExe;ã BlockRead(ExeFile, ExeHdr, SizeOf(ExeHdr));ã if ExeHdr.Len = 0 thenã ExeHdr.Len := $200;ã ExeLoc := (longint(ExeHdr.Pages) - 1) shl 9 + longint(ExeHdr.Len);ã Seek(ExeFile, ExeLoc);ã BlockRead(ExeFile, DataCount, 1); { read data count byte }ã Inc(ExeLoc);ã GetMem(Data, SizeOf(DataRec) * DataCount);ã for I := 1 to DataCount doã beginã Seek(ExeFile, ExeLoc);ã BlockRead(ExeFile, ExeData, SizeOf(ExeData));ã Data^[I].Loc := ExeLoc;ã Data^[I].Size := ExeData.ActSize;ã Inc(ExeLoc, ExeData.ActSize + 2);ã end;ã CloseExe;ãend;ããfunction GetSize(N : byte) : word;ãbeginã if N > DataCount thenã RunError(201);ã GetSize := Data^[N].Size;ãend;ããfunction GetData(N : byte) : pointer;ãvarã P, D : pointer;ã DataLoc : longint;ã E : ExeDataRec;ãbeginã if N > DataCount thenã RunError(201);ã GetMem(P, Data^[N].Size);ã OpenExe;ã Seek(ExeFile, Data^[N].Loc + 2); { +2 is to get past info record }ã BlockRead(ExeFile, P^, Data^[N].Size);ã CloseExe;ã GetData := P;ãend;ããfunction GetDataCount : byte;ãbeginã GetDataCount := DataCount;ãend;ããbeginã InitExe;ãend.ãã{ãOk.. that's it. Call GetData(x) to get the location of the firstãelement. Datacount is the number of GIFs or whatever you have in thereãand the first two bytes are the actual size.. So to add a file, justãmake a temp file called ADDED.DAT, write a byte value for the datacount,ãand a word value for the filesize of the data you're adding, and thenãthe data. Hope this help all of you who wanted to be able to add ANSis,ãGIFs, and whatnot onto exes. Also, with little modification, you canãmake it read from .DAT files with multiple gifs and stuff in them.ã}ã 32 08-27-9320:55ALL GABE KRUPA Modify EXE constants IMPORT 65 oï (*ãGABE KRUPAãã> I need to add some information to the end of an EXE file and be ableã> Say a PCX image for example. I'm concerned about the EXE file alreadã> open due to being executed. Does info tacked to the end of an EXE geã> into memory automatically, etc. I haven't tried this yet but am abouã> hoping someone who has tried it can assist me to avoid some of the piã> they may have encountered. Thanks. (BTW, I am experienced in Pas &ãã Well, I made a unit for that purpose, but my unit only tacks on 1K ofãstorage space... You can make it as large as you want it, but it'll be aãREAL time consumer and it might push your text editor to the limits (I'mãnot sure if the IDE has a file size limit).ãã Here it is (in a VERY shortened version )ã}ãunit inject1k;ããinterfaceãimplementationãconst doesnt_matter_what_this_is_called : boolean = false;ããprocedure never_really_call_this_procedure;ãbeginã if doesnt_matter_what_this_is_called thenã inline( 228/229/230/231/231/233/234/ { this I use for a ID string }ã 234/234/234/234/234/234/234/ã 234/234/234/234/243/234/234/ã{ repeat as many times until you get enough .. each '234/' is 1 byte }ã 234/234/234/234/234/234/234/ã 234/234/234/234/234/234/234/ { this is the actual 'junk' }ã ); { inline }ãend; { procedure }ããend. { unit }ã{ã I only inject 1024 into my EXE file... If you want, you can makeãidentical units like that, but the DATA area will NOT be in one longãstring unless all the bytes are in one unit.ã I use the ID string to correctly place the file pointer. Just open theãEXE, read in bytes until you get a 228. Read another, if it's a 229ãetc.. Keep looping until you get a 228-229-230-231-232-233-234 and thenãyou can start reading/writing. It's by no means the easiest way, but Iãprefer it over trying to append to the end. I tried that, but I keptãgetting errors and such. As long as the PCX file is fairly small, youãwon't have too much of a problem.ã I'm not sure what the chances are, they must be pretty slim to find aãstring (228-234) one after the other in an EXE. If you think they areãhigher, or whatever, just put your own in. You could probably even putãtext in like this:ã}ãinline('D'/'A'/'T'/'A'/' '/'S'/'T'/'A'/'R'/'T'/'S'/' '/'H'/'E'/'R'/'E'/ã111/111/111/111 { etc... } );ã{ã I hope this helps, or gives you some ideas. Note, the unit willãbe about TWICE as large as the number of bytes you inject (maybe 1000ãmore), but the EXE will only increse by the number you add. I'm prettyãsure that the extra bytes are just data/debug info in the TPU file.ã*)ãã{ãMARK LEWISãã> I need to add some information to the end of an EXE file and be ableã> Say a PCX image for example. I'm concerned about the EXE file alreadãã[... trim ...]ãã> Well, I made a unit for that purpose, but my unit only tacks onã> 1K of storage space... You can make it as large as you want it,ã> but it'll be a REAL time consumer and it might push your textã> editor to the limits (I'm not sure if the IDE has a file sizeã> limit). Here it is (in a VERY shortened version )ã> unit inject1k;ãã[... trim ...]ããinteresting<>... i never thought of doing it like that.. hehe.. here'sãa unit i got from this echo or the other PASCAL echo several years ago.. i'veãused it in self-limiting programs (ones that only run a certain number ofãtimes) and other programs that may be subject to hacking of various forms...ãi've modified it slightly for my purposes...ã}ãunit selfmod;ãã{ Allows a program to self modify a typed constant in the .exe file. It }ã{ also performs an automatic checksum type .exe file integrity check. }ã{ A longint value is added to the end of the exe file. This can be read by }ã{ a separate configuration program to enable it to determine the start of }ã{ the programs configuration data area. To use this the configuration }ã{ typed constant should be added immediately following the declaration of }ã{ ExeData. }ã{ Where this unit is used, it should always be the FIRST unit listed in the }ã{ uses declaration area of the main program. }ã{ Requires DOS 3.3 or later. Program must not be used with PKLite or LZExe }ã{ or any similar exe file compression programs. }ã{ The stack size needed is at least 9,000 bytes. }ããinterfaceããtypeã ExeDatatype = recordã IDStr : string[8];ã FirstTime : boolean;ã Hsize : word;ã ExeSize : longint;ã CheckSum : longint;ã StartConst : longint;ã end;ããconstã ExeData : ExeDatatype = (IDStr : 'IDSTRING';ã FirstTime : true;ã Hsize : 0;ã ExeSize : 0;ã CheckSum : 0;ã StartConst: 0);ãã{ IMPORTANT: Put any config data typed constants here }ããprocedure Write2Exec(var data; size: word);ãã{============================================================================}ããimplementationããprocedure InitConstants;ã varã f : file;ã tbuff : array[0..1] of word;ãã function GetCheckSum : longint;ã { Performs a checksum calculation on the exe file }ã varã finished : boolean;ã x,ã CSum : longint;ã BytesRead : word;ã buffer : array[0..4095] of word;ã beginã {$I-}ã seek(f,0);ã finished := false; CSum := 0; x := 0;ã BlockRead(f,buffer,sizeof(buffer),BytesRead);ã while not finished do begin { do the checksum calculations }ã repeat { until file has been read up to start of config area }ã inc(CSum,buffer[x mod 4096]);ã inc(x);ã finished := ((x shl 1) >= ExeData.StartConst);ã until ((x mod 4096) = 0) or finished;ã if not finished then { data area has not been reached }ã BlockRead(f,buffer,sizeof(buffer),BytesRead);ã end;ã GetCheckSum := CSum;ã end;ãã beginã assign(f, ParamStr(0));ã {$I-} Reset(f,1);ã with ExeData do beginã if FirstTime and (IOResult = 0) then beginã Seek(f,2); { this location has the executable size }ã BlockRead(f,tbuff,4);ã ExeSize := tbuff[0]+(pred(tbuff[1]) shl 9);ã seek(f,8); { get the header size }ã BlockRead(f,hsize,2);ã FirstTime := false;ã StartConst := longint(hsize+Seg(ExeData)-PrefixSeg) shl 4 +ã Ofs(ExeData) - 256;ã CheckSum := GetCheckSum;ã Seek(f,StartConst);ã BlockWrite(f,ExeData,sizeof(ExeData));ã seek(f,FileSize(f));ã BlockWrite(f,StartConst,4);ã endã elseã if GetCheckSum <> CheckSum then beginã writeln;ã writeln(#7,#7,'Program file has been UNLAWFULLY modified!',#7,#7);ã writeln;ã writeln('It may have a Virus attached or someone may have made');ã writeln('an attempt to HACK it. You should check your system for');ã writeln('virus'' before continuing....');ã writeln;ã writeln('Please reinstall the .EXE file from the original archive.');ã writeln('Aborting....');ã halt(255);ã endã elseã beginã writeln;ã writeln('Integrity Validated.');ã end;ã end; { with }ã Close(f); {$I+}ã if IOResult <> 0 then beginã writeln('Unable to initialise program');ã halt;ã end;ã end; { InitConstants }ããprocedure Write2Exec(var data; size: word);ã { writes a new typed constant into the executable file. }ã varã f : file;ã beginã assign(f, ParamStr(0));ã {$I-} Reset(f,1);ã Seek(f,longint(ExeData.Hsize+Seg(data)-PrefixSeg) shl 4 + Ofs(data)- 256);ã BlockWrite(f,data,size);ã Close(f); {$I+}ã if IOResult <> 0 then;ã end; { Write2Exec }ããbeginã writeln('Please Standby...');ã InitConstants;ãend.ãã 33 08-27-9321:01ALL STEVE ROGERS True EXE Size IMPORT 12 oÑ {ãSTEVE ROGERSãã> Also, does anyone know how PKware wrote the ZIP2EXE Program? I'm alsoã>writing an encryption Program, and I thought a 'self-decrypting' Fileã>would be neat, so I had some ideas on how to do it. Could you justã>append the encrypted data to the end of a short 'stub' Program, whichã>just seeks in how ever many Bytes and reads from there? Or would Iã>have to somehow assign all the data to a few Typed Constants?ããJust so happens I have been dealing With the same problem. I haveãwritten a Procedure to show the "True" size of an EXE File. Knowing thisãyou can easily get to your "data area" by seeking past the "True" size.ãã( Acknowledgements to Andy McFarland and Ray Duncan )ã}ããFunction exesize(fname : String) : LongInt;ãTypeã t_size = Recordã mz : Array [1..2] of Char;ã remainder,ã pages : Word;ã end;ããVarã f : File of t_size;ã sz : t_size;ããbeginã assign(f,fname);ã {$i-}ã reset(f);ã {$i+} { io checking should be off }ã if (ioresult <> 0) thenã exesize:= 0ã elseã beginã read(f,sz);ã close(f);ã With sz doã exesize := remainder + (pred(pages) * 512);ã end;ãend;ããã{ãThis thing reads the header of an EXE File and gets the info there. Iãwas amazed when I ran this on a bunch of progs and found how many haveãdata appended. Hope it helps. :)ã} 34 08-27-9321:23ALL GERD KORTEMEYER Detect Float Error IMPORT 132 o? {ãGERD KORTEMEYERããhere are two Units For trapping float-exceptions. In your Program youãwill have to addãã Uses err387ããand at the beginning of your main Program say For exampleããbeginã exception(overflow, masked);ã exception(underflow, dumpask);ã exception(invalid, dumpexit);ã autocorrect(zerodiv, 1.0);ã exception(precision, masked);ããIn this way you can choose For any kind of exception in which way it isãto be handeled. After the lines above the result of a division by zeroãwill be '1.0', in Case of an underflow there will be a dump of the coproãand the user will be asked For the result he wants the operation to have,ãin Case of an overflow the largest available number will be chosen andãso on ...ããHere are the Unitsãã err387 and dis387ã}ãã{ ---------------------------------------------------------- }ã{ Fehlerbehandlungsroutinen fuer den Intel 80387 bzw. 486 DX }ã{ Geschrieben in Turbo Pascal 6.0 }ã{ von Gerd Kortemeyer, Hannover }ã{ ---------------------------------------------------------- }ããUnit err387;ããInterfaceããUsesã dis387, Dos, Crt;ããConstã invalid = 1;ã denormal = 2;ã zero_div = 4;ã overflow = 8;ã underflow = 16;ã precision = 32;ã stackfault= 64;ã con1 = 512;ãã masked = 0;ã runtime = 1;ã dump = 2;ã dumpexit = 3;ã dumpask = 4;ã autocorr = 5;ãããProcedure exception(which, what : Word);ãProcedure autocorrect(which : Word; by : Extended);ããProcedure handle_off;ãProcedure handle_on;ããProcedure restore_masks;ããProcedure clear_copro;ãFunction status_Word : Word;ããVarã do_again : Word;ããImplementationããConstã valid = 0;ã zero = 1;ã spec = 2;ã empty = 3;ãã topmask : Word = 14336;ã topdiv = 2048;ãã anyerrors : Word = 63;ãã zweipot : Array [0..15] of Word =ã (1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,ã 2048, 4096, 8192, 16384, 32768);ãã ex_nam : Array[0..5] of String=ã ('Invalid ',ã 'Denormal ',ã 'Zero-Div ',ã 'Overflow ',ã 'Underflow ',ã 'Precision ');ããVarã setmasks : Byte;ã normal : Recordã Case Boolean OFã True : (adr : Pointer);ã False: (pro : Procedure);ã end;ãã Exit_on,ã dump_on,ã ask_on,ã auto_on,ã standard : Word;ãã auto_val : Array [0..5] of Extended;ããProcedure Mask(which : Word);ãVarã cw : Word;ãbeginã Asmã fstcw cwã end;ã cw := cw or which;ã setmasks := Lo(cw);ã Asmã fldcw cwã end;ãend;ããProcedure Unmask(which : Word);ãVarã cw : Word;ãbeginã Asmã fclexã fstcw cwã end;ã cw := cw and not (which);ã setmasks := Lo(cw);ã Asmã fldcw cwã end;ãend;ããProcedure restore_masks;ãVarã setm : Word;ã i :Integer;ãbeginã setm:=setmasks;ã For i := 0 to 5 doã if (setm and zweipot[i]) <> 0 thenã Mask (zweipot[i])ã elseã Unmask(zweipot[i]);ãend;ããProcedure clear_copro;ãVarã cw : Word;ãbeginã Asmã fstcw cwã end;ã setmasks := Lo(cw);ã Asmã finitã end;ãend;ããFunction status_Word;ãbeginã Asmã fstsw @resultã end;ãend;ãã{ Bei welcher Exception soll was passieren? }ãProcedure exception;ãbeginã Case what OFãã masked : Mask(which);ãã runtime :ã beginã Unmask(which);ã standard := standard or which;ã end;ãã dump :ã beginã Unmask(which);ã standard := standard and NOT(which);ã dump_on := dump_on or which;ã Exit_on := Exit_on and NOT(which);ã ask_on := ask_on and NOT(which);ã auto_on := auto_on and NOT(which);ã end;ãã dumpexit :ã beginã Unmask(which);ã standard := standard and NOT(which);ã dump_on := dump_on or which;ã Exit_on := Exit_on or which;ã ask_on := ask_on and NOT(which);ã auto_on := auto_on and NOT(which);ã end;ãã dumpask :ã beginã Unmask(which);ã standard := standard and NOT(which);ã dump_on := dump_on or which;ã Exit_on := Exit_on and NOT(which);ã ask_on := ask_on or which;ã auto_on := auto_on and NOT(which);ã end;ã end;ãend;ãã{ zum Setzen von Auto-Korrekt-Werten }ããProcedure autocorrect;ãVarã i : Integer;ãbeginã Unmask(which);ã standard := standard and NOT(which);ã dump_on := dump_on and NOT(which);ã Exit_on := Exit_on and NOT(which);ã ask_on := ask_on and NOT(which);ã auto_on := auto_on or which;ã For i := 0 to 5 doã if (which and zweipot[i]) <> 0 thenã auto_val[i] := by;ãend;ãã{ ------------- Die Interrupt-Routine selbst ------------- }ããProcedure errorcon; Interrupt;ãVarã copro : Recordã control_Word,ã status_Word,ã tag_Word, op,ã instruction_Pointer,ã ip, operand_Pointer, : Word;ã st : Array [0..7] of Extended;ã end;ãã top : Integer; { welches Register ist Stacktop? }ãã masked, { welche Exceptions maskiert? }ã occured : Byte; { welche Exceptions aufgetreten? }ãã opcode : Word;ãã inst_seg, { Instruction-Pointer, Segment }ã inst_off, { " , Offset }ã oper_seg, { Operand-Pointer , Segment }ã oper_off: Word; { " , Offset }ãã inst_point : ^Word; { zum Adressieren des Opcodes }ãã oper_point : Recordã Case Integer of { zum Adressieren des Operanden }ã 1 : (ex : ^Extended);ã 2 : (db : ^Double);ã 3 : (si : ^Single);ã 4 : (co : ^Comp);ã end;ãã marker: Array [0..7] of Word; { Register-Marker nach Tag-Word }ãã opt_dump, { soll ausgeben werden? }ã opt_exit, { soll aufgehoert werden? }ã opt_ask, { soll Ergebnis abgefragt werden? }ã opt_auto : Boolean; { soll Ergebnis automatisch korrigiert werden? }ãã i : Integer;ãã mem_access: Boolean; { gibt es Speicherzugriff? }ãã op_name : String; { Mnemonik des Befehls }ãã{ Ersetze Stacktop durch abgefragten Wert }ãProcedure ask_correct;ãVarã res : Extended;ã ch : Char;ã t : String;ã code : Integer;ãbeginã Asmã fstp resã end;ã WriteLN;ã Write('The result would be ', res, '. Change? (y/n) ' );ã Repeatã Repeat Until KeyPressed;ã ch := ReadKey;;ã Until ch in ['Y','y','N','n'];ã Writeln;ã if ch in ['Y','y'] thenã Repeatã Write('New value : ');ã READLN(t);ã VAL(t, res, code);ã Until code = 0;ã Asmã fld resã end;ãend;ããFunction hex(w : Word) : String; { Ausgabe als HeX-Zahl }ãConstã zif : Array [0..15] of Char = ('0','1','2','3','4','5','6','7','8','9',ã 'a','b','c','d','e','f');ãbeginã hex := zif[w div zweipot[12]] +ã zif[(w MOD zweipot[12]) div zweipot[8]] +ã zif[(w MOD zweipot[8]) div zweipot[4]] +ã zif[w MOD zweipot[4]];ãend;ããProcedure choice;ãVarã ch : Char;ãbeginã WriteLN;ã Write('C)ontinue, A)bort ');ã Repeatã Repeat Until KeyPressed;ã ch:=ReadKey;;ã if ch in ['A','a'] thenã Halt(0);ã Until ch in ['C','c'];ã WriteLN;ãend;ããProcedure showcopro; { Ausgeben des FSAVE - Records }ãVarã i : Integer;ãbeginã TextMode(LastMode);ã HighVideo;ã WriteLN('Floating point exception, last opcode: ',hex(opcode),ã ' (',op_name,')');ã NormVideo;ã WriteLN('Instruction Pointer : ',hex(inst_seg),':',hex(inst_off),ã ' (',hex(inst_point^),')');ã if mem_access thenã beginã WriteLN('Operand Pointer : ',hex(oper_seg),':',hex(oper_off));ã WriteLN('( Extended: ',oper_point.ex^,', Double: ',oper_point.db^);ã WriteLN(' Single : ',oper_point.si^,', Comp : ',oper_point.co^,' )');ã endã elseã beginã WriteLN;ã WriteLN ('No memory access');ã WriteLN;ã end;ã HighVideo;ã if (occured and stackfault) = 0 thenã beginã WriteLN('Exception ','Masked':8,'Occured':8,'Should be masked':18);ã NormVideo;ã For i:=0 to 5 doã WriteLN(ex_nam[i], (masked and zweipot[i]) <> 0 : 8,ã (occured and zweipot[i]) <> 0 : 8,ã (setmasks and zweipot[i]) <> 0 : 18);ã HighVideo;ã endã elseã beginã WriteLN('Invalid Operation:');ã if (copro.status_Word and con1) <> 0 thenã WriteLN(' -- Stack Overflow --')ã elseã WriteLN(' -- Stack Underflow --');ã WriteLN;ã end;ãã WriteLN('Reg ','Value':29,'Marked':10);ã Normvideo;ã For i := 0 to 7 doã beginã Write('st(',i,')', copro.st[i] : 29);ã Case marker[i] OFã valid : WriteLN('Valid' : 10);ã spec : WriteLN('Special' : 10);ã empty : WriteLN('Empty' : 10);ã zero : WriteLN('Zero' : 10);ã end;ã end;ãend;ãã{ Ersetze Stacktop durch Auto-Korrekt-Wert }ããProcedure auto_corr;ãVarã res : Extended;ã i : Integer;ãbeginã Asmã fstp resã end;ã For i := 0 to 5 doã if ((occured and zweipot[i]) <> 0) andã ((auto_on and zweipot[i]) <> 0) thenã res := auto_val[i];ã Asmã fld resã end;ãend;ãããProcedure do_it_again;ãTypeã codearr = Array[0..4] of Byte;ãVarã sam : Recordã Case Boolean OFã True : (b: ^codearr );ã False: (p: Procedure);ã end;ãã op_point : Pointer;ã x : extended;ãbeginã New(sam.b);ã sam.b^[0]:=Hi(opcode);ã sam.b^[1]:=Lo(opcode);ã if mem_access thenã beginã { --- mod r/m auf ds:[di] stellen (00ttt101) --- }ã sam.b^[1] := sam.b^[1] and not (zweipot[7] + zweipot[6] + zweipot[1]);ã sam.b^[1] := sam.b^[1] or (zweipot[2] + zweipot[0]);ã end;ã sam.b^[2] := $ca; { retf 0000 }ã sam.b^[3] := $00;ã sam.b^[4] := $00;ã op_point := oper_point.ex;ã Asmã push dsã lds di, op_pointã end;ãã sam.p;ãã Asmã pop dsã end;ã Dispose(sam.b);ãend;ããbeginã Asmã push axã xor al,alã out 0f0h,alã mov al,020hã out 0a0h,alã out 020h,alã pop axã fsave coproã end;ãã { === Pruefen, ob Bearbeitung durch ERRORCON erwuenscht === }ã if (copro.status_Word and standard) <> 0 thenã beginã Asmã frstor coproã end;ã normal.pro; { Bye, bye ... }ã end;ã { === Auswerten des FSAVE-Records ========================= }ã { --- Opcode wie im Copro gespeichert --- }ã opcode := zweipot[15] + zweipot[14] + zweipot[12] + zweipot[11] +ã (copro.ip MOD zweipot[11]);ã op_name := dis(opcode);ã mem_access := op_name='...';ã { --- Was war maskiert, was ist passiert? --- }ã masked := Lo(copro.control_Word);ã occured := Lo(copro.status_Word );ã { --- Der Instruction-Pointer --- }ã inst_seg := copro.ip and (zweipot[15] + zweipot[14] + zweipot[13] +ã zweipot[12]);ã inst_off := copro.instruction_Pointer;ã inst_point := Ptr(inst_seg,inst_off);ã { --- Der Operand-Pointer --- }ã oper_seg := copro.op and (zweipot[15] + zweipot[14] + zweipot[13] +ã zweipot[12]);ã oper_off := copro.operand_Pointer;ã oper_point.ex := Ptr(oper_seg,oper_off);ã { --- Wer ist gerade Stacktop? --- }ã top := (copro.status_Word and topmask) div topdiv;ã { --- Einlesen der Marker aus Tag-Word --- }ã For i := 0 to 7 doã beginã marker[(8 + i - top) MOD 8] := (copro.tag_Word and (zweipot[i * 2] +ã zweipot[i * 2 + 1])) div zweipot[i * 2];ã end;ãã { --- Welche Aktionen sollen ausgefuehrt werden? --- }ã opt_dump := (copro.status_Word and dump_on) <> 0;ã opt_exit := (copro.status_Word and Exit_on) <> 0;ã opt_ask := (copro.status_Word and ask_on ) <> 0;ã opt_auto := (copro.status_Word and auto_on) <> 0;ãã { === Aktionen ============================================ }ã if opt_dump thenã showcopro;ã if opt_exit thenã beginã WriteLN;ã WriteLN('Exit Program due to Programmers request');ã HALT; { Bye, bye ... }ã end;ã if opt_dump and not (opt_ask) thenã choice;ãã copro.control_Word := copro.control_Word or anyerrors;ã Asmã frstor coproã fclexã end;ã { --- Befehl nochmals ausfuehren --- }ã if (occured and do_again) <> 0 thenã do_it_again;ã { --- Noch was? --- }ã if opt_auto thenã auto_corr;ã if opt_ask thenã ask_correct;ã restore_masks;ãend;ãã{ ------------- Ein- und Ausschalten ------------- }ããProcedure handle_on;ãbeginã Getintvec($75, normal.adr);ã Setintvec($75, @errorcon);ãend;ããProcedure handle_off;ãbeginã Setintvec($75, normal.adr);ãend;ããbeginã handle_on;ã dump_on :=0;ã Exit_on :=0;ã ask_on :=0;ã auto_on :=0;ã standard:=0;ã do_again:=invalid+zero_div+denormal;ã clear_copro;ãend.ãããããããUnit dis387;ããInterfaceããFunction dis(opco : Word) : String;ããImplementationããFunction dis;ãVarã d, op : String;ãã Procedure opcr(st : Word);ã Varã t : String;ã beginã str(st, t);ã op := ' st,st(' + t + ')';ã end;ãã Procedure opc(st : Word);ã Varã t : String;ã beginã str(st, t);ã op := ' st(' + t + '),st';ã end;ãã Procedure op1(st : Word);ã Varã t : String;ã beginã str(st, t);ã op := ' st(' + t + ')';ã end;ããbeginã d := '...';ã op := '';ãã Case Hi(opco) OFã $d8 :ã Case Lo(opco) div 16 OFã $c :ã if opco MOD 16 >= 8 thenã beginã d := 'fmul';ã opcr(opco MOD 16 - 8);ã endã elseã beginã d := 'fadd';ã opcr(opco MOD 16);ã end;ãã $e :ã if opco MOD 16 >= 8 thenã beginã d := 'fsubr';ã opcr(opco MOD 16 - 8);ã endã elseã beginã d := 'fsub';ã opcr(opco MOD 16);ã end;ãã $f :ã if opco MOD 16 >= 8 thenã beginã d := 'fdivr';ã opcr(opco MOD 16 - 8);ã endã elseã beginã d := 'fdiv';ã opcr(opco MOD 16);ã end;ã end;ãã $d9 :ã Case Lo(opco) OFã $d0 : d := 'fnop';ã $e0 : d := 'fchs';ã $e1 : d := 'fabs';ã $e4 : d := 'ftst';ã $e5 : d := 'fxam';ã $e8 : d := 'fld1';ã $e9 : d := 'fld2t';ã $ea : d := 'fld2e';ã $eb : d := 'fldpi';ã $ec : d := 'fldlg2';ã $ed : d := 'fldln2';ã $ee : d := 'fldz';ã $f0 : d := 'f2xm1';ã $f1 : d := 'fyl2x';ã $f2 : d := 'fptan';ã $f3 : d := 'fpatan';ã $f4 : d := 'fxtract';ã $f5 : d := 'fprem1';ã $f6 : d := 'fdecstp';ã $f7 : d := 'fincstp';ã $f8 : d := 'fprem';ã $f9 : d := 'fyl2xp1';ã $fa : d := 'fsqrt';ã $fb : d := 'fsincos';ã $fc : d := 'frndint';ã $fd : d := 'fscale';ã $fe : d := 'fsin';ã $ff : d := 'fcos';ã end;ãã $db :ã Case Lo(opco) OFã $e2 : d := 'fclex';ã $e3 : d := 'finit';ã end;ã $dc :ã Case Lo(opco) div 16 OFã $c :ã if opco MOD 16 >= 8 thenã beginã d := 'fmul';ã opc(opco MOD 16-8);ã endã elseã beginã d := 'fadd';ã opc(opco MOD 16);ã end;ãã $e : if opco MOD 16 >= 8 thenã beginã d := 'fsub';ã opc(opco MOD 16 - 8);ã endã elseã beginã d := 'fsubr';ã opc(opco MOD 16);ã end;ãã $f :ã if opco MOD 16 >= 8 thenã beginã d := 'fdiv';ã opc(opco MOD 16 - 8);ã endã elseã beginã d := 'fdivr';ã opc(opco MOD 16);ã end;ã end;ãã $dd :ã Case Lo(opco) div 16 OFã $c :ã beginã d := 'ffree';ã op1(opco MOD 16);ã end;ã $d :ã if opco MOD 16 >= 8 thenã beginã d := 'fstp';ã op1(opco MOD 16 - 8);ã endã elseã beginã d := 'fst';ã op1(opco MOD 16);ã end;ã $e :ã if opco MOD 16 >= 8 thenã beginã d := 'fucomp';ã op1(opco MOD 16 - 8);ã endã elseã beginã d := 'fucom';ã op1(opco MOD 16);ã end;ã end;ãã $de :ã Case Lo(opco) div 16 OFã $c :ã if opco MOD 16 >= 8 thenã beginã d := 'fmulp';ã opc(opco MOD 16 - 8);ã endã elseã beginã d := 'faddp';ã opc(opco MOD 16);ã end;ãã $d : d := 'fcompp';ãã $e :ã if opco MOD 16 >= 8 thenã beginã d := 'fsubp';ã opc(opco MOD 16 - 8);ã endã elseã beginã d := 'fsubrp';ã opc(opco MOD 16);ã end;ãã $f :ã if opco MOD 16 >= 8 thenã beginã d := 'fdivp';ã opc(opco MOD 16 - 8);ã endã elseã beginã d := 'fdivrp';ã opc(opco MOD 16);ã end;ã end;ã end;ãã dis := d + op;ãend;ããbeginãend.ã 35 08-27-9321:40ALL SEAN PALMER Simple Multi-Tasker IMPORT 22 og% {ã by Sean L. Palmerã Public Domainãã This is a 'multitasking' Program in the sense that it hooks intoã the timer interrupt, but what that interrupt ends up actuallyã doing is controlled by the current value in SaveAdr, whichã changes With each interrupt as the routine passes control backã to the tick handler not by Exiting normally, but by an explicitã transfer of control.ã The end result of this is that you can Write a state-drivenã interrupt handlerã The included example is RealLY simplistic, and barely tested.ã I intend to use this to Write a comm port driver thatã parses the incoming data as it receives it which wouldã be nice in a communications Program that shells to Dos, asã the incoming Chars could be saved to disk in the backgroundã With buffered ZModem or something...ã}ããProgram intTest;ããUsesã Dos;ããVarã saveAdr : Word; {offset in this code segment of where we are now}ã active : Boolean; {to avoid re-entrancy}ããProcedure intHandler; Far; Assembler;ãAsmã pushaã mov ax, seg @DATAã mov ds, axãã {anything you need to do before continuing (reading port data?), do here}ãã in al, $61 {click speaker as an example}ã xor al, 2ã out $61, alãã test active, $FF {exit now if interrupted ourselves}ã jz @OKã popaã iretãã @OK:ã inc Byte ptr activeã stiã jmp [saveAdr] {near jump to continue where handler last left off}ãend;ãã{call this Procedure from StateHandler to suspend execution Until next time}ããProcedure wait; near; Assembler;ãAsm {wait For next interrupt}ã pop Word ptr saveAdr {save where to continue next time}ã dec Byte ptr activeã popa {restore caller regs}ã iretãend;ããConstã c : Char = '.';ããProcedure stateHandler;ãbeginã{ã a stateHandler Procedure should never ever Exit (only by calling 'wait'),ã shouldn't have any local Variables or parameters, and shouldn't callã 'wait' With anything on the stack (like from a subroutine).ã This routine is using the caller's (interrupted Program's) stack, so beã very very careful}ãã Asmã pop bp {clean up stack mess left by Turbo's Procedure header}ã end;ã {^ alternative method here is to init saveAdr to offset(proc)+3 and skipã the push bp; mov bp,sp altogether}ãã Repeat {this is an example only}ã c := '@';ã wait;ã c := '.';ã wait;ã Until False; {don't let it return normally!!}ãend;ããVarã oldHook : Procedure;ã i : Integer;ããbeginã saveAdr := ofs(stateHandler);ã getIntVec($1C, @oldHook);ã setIntVec($1C, @intHandler);ã For i := 1 to 1500 doã Write(c);ã setIntVec($1C, @oldHook);ãend.ããã 36 08-27-9322:12ALL DAVID DOTY Writing To EXE File IMPORT 73 os¨ {ã> How are you saaving the CFG into the .EXE?? Mind posting some code that wilã> save the CFG to the EXE?(When you get all your bugs fixed!)ããI use these routines in my self-modifying .EXE's. They work pretty good.ã}ããUnit WritExec;ãã { ==================================================================ãã Unit: WritExecã Author: David Dotyã Skipjack Softwareã Columbia, Marylandã CompuServe User I.D.: 76244,1043ãã This Unit is based on a previously published Program:ãã Program: AutoInst v2.0ã Author: David Duboisã Zelkop Softwareã Halifax, Nova Scotiaã CompuServe User I.D.: 71401,747ã Date last revised: 1988.04.24ãã ==================================================================ãã This source code is released to the public domain. if further changesã are made, please include the above credits in the distributed code.ãã This Unit allows a Program to change the value of a Typed Constant in itsã own .EXE File. When the Program is run again, the data will be initializedã to the new value. No external configuration Files are necessary.ãã Usesãã Examples of the usefulness of this technique would be:ãã o A Program that allows the user to change default display colors.ãã o A Program that keeps track of a passWord that the user can change.ãã HOW IT WORKSãã You don't have to understand all the details in order to use thisã technique, but here they are.ãã The data to be changed must be stored in a TurboPascal Typedã Constant. In all effect, a Typed Constant is actually a pre-ã initialized Variable. It is always stored in the Program's Dataã Segment. The data can be of any Type.ãã First, the Procedure finds the .EXE File by examining the Dos commandã line, stored With the copy of the Dos environment For the Program. Thisã allows the Program to find itself no matter where is resides on disk andã no matter how its name is changed by the user.ãã The unTyped File is opened With a Record size of 1. This allows usã to read or Write a String of Bytes using BlockRead and BlockWrite.ãã As documented in the Dos Technical Reference, the size of the .EXEã header, in paraGraphs (a paraGraph is 16 Bytes), is stored as aã two-Byte Word at position 8 of the File. This is read into theã Variable HeaderSize.ãã The next step is to find the position of the Typed Constant in theã .EXE File. This requires an understanding of the Turbo Pascal 4.0ã memory map, documented on the first and second pages of the Insideã Turbo Pascal chapter. (That's chapter 26, pages 335 and 336 in myã manual.)ãã First, find the address in memory where the Typed Constant isã stored. This can be done in Turbo Pascal by using the Seg and Ofsã Functions. Next find the segment of the PSP (Program segmentã prefix). This should always be the value returned by PrefixSeg.ã That will mark the beginning of the Program in memory. Theã position of the Typed Constant in the .EXE image should be theã number of Bytes between these two places in memory. But ...ãã But, two corrections must be made. First, the PSP is not stored inã the .EXE File. As mentioned on page 335, the PSP is always 256ã Bytes. We must subtract that out. Secondly, there is the .EXE Fileã header. The size of this has already been read in and must beã added in to our calculations.ãã Once the position has been determined, the data stored in theã Typed Constant is written in one fell swoop using a BlockWrite.ã This replaces the original data, so that the next time the Programã is run, the new values will used.ãã LIMITATIONSãã You cannot use MicroSoft's EXEPACK on the .EXE File, or any otherã packing method I know of. This may change the position, or evenã the size of the Typed Constant in the File image.ãã NOTESãã Since Typed Constants are always stored in the data segment, theã Function call to Seg( ObjectToWrite ) can be replaced With DSeg. Iã prefer using Seg since it is more descriptive.ãã One might think that Cseg can used as an alternative to usingã PrefixSeg and subtracting 256. This will work only if the codeã resides in the main Program. If, on the other hand, the code isã used in a Unit, PrefixSeg must be used as described here. Youã might as well use PrefixSeg and save yourself some headaches.ãã if you have any comments or questions we would be glad to hearã them. if you're on CompuServe, you can EasyPlex a letter toã 76244,1043 or 71401,747. Or leave a message on the Borland Programmer's Aã Forum (GO BPROGA). Or, you can Write toãã Skipjack Softwareã P. O. Box 61ã Simpsonville Maryland 21150ãã orãã Zelkop Softwareã P.O. Box 5177ã Armdale, N.S.ã Canadaã B3L 4M7ãã ==================================================================}ãããInterfaceããFunction GetExecutableName : String;ã{ This Function returns the full drive, path, and File name of the applicationã Program that is running. This Function is of more general interest thanã just For writing into the EXE File.ãã NOTE: THIS Function WILL ONLY WORK UNDER Dos 3.X + !!! }ããFunction WriteToExecutable(Var ObjectToWrite; ObjectSize : Word) : Integer;ã{ This Procedure modifies the EXE File on disk to contain changes to Typedã Constants. NOTE - the Object MUST be a Typed Constant. It may be foundã in any part of the Program (i.e., main Program or any Unit). The call isã made by unTyped address, to allow any kind of Object to be written. Theã Function returns the Dos error code from the I/O operation that failedã (if any did); if all operations were successful, the Function returns 0. }ããImplementationããFunction GetExecutableName : String;ãTypeã Environment = Array[0..32766] of Char;ãConstã NullChar : Char = #0;ã SearchFailed = $FFFF;ãVarã MyEnviron : ^Environment;ã Loop : Word;ã TempWord : Word;ã EnvironPos : Word;ã FilenamePos : Word;ã TempString : String;ãbegin { Function GetExecutableName }ã { Get Pointer to Dos environment }ã MyEnviron := Ptr(MemW[PrefixSeg : $2C], 0);ãã { Look For end of environment }ã EnvironPos := SearchFailed;ã Loop := 0;ãã While Loop <= 32767 DOã beginã if MyEnviron^[ Loop ] = NullChar thenã if MyEnviron^[ Loop + 1 ] = NullChar thenã begin { found two nulls - this is end of environment }ã EnvironPos := Loop;ã Loop := 32767ã end; { found two nulls }ã Inc(Loop);ã end; { While Loop }ãã if EnvironPos = SearchFailed thenã GetExecutableName := ''ã elseã begin { found end of environment - now look For path/File of exec }ã EnvironPos := EnvironPos + 4;ã FilenamePos := SearchFailed;ã TempWord := EnvironPos;ã Loop := 0;ãã While Loop <= 127 DOã beginã if MyEnviron^[TempWord] = NullChar thenã begin { found a null - this is end of path/File of exec }ã FilenamePos := Loop;ã Loop := 127ã end; { found a null }ã Inc(Loop);ã Inc(TempWord);ã end; { While Loop }ãã if FilenamePos = SearchFailed thenã GetExecutableName := ''ã elseã begin { found executable name - move into return String }ã TempString[0] := Chr(FilenamePos);ã Move(MyEnviron^[EnvironPos], TempString[1], FilenamePos);ã GetExecutableName := TempString;ã end; { found executable name }ã end; { found environment end }ãend; { Function GetExecutableName }ãããFunction WriteToExecutable(Var ObjectToWrite; ObjectSize : Word ) : Integer;ãConstã PrefixSize = 256; { number of Bytes in the Program Segment Prefix }ãVarã Executable : File;ã HeaderSize : Word;ã ErrorCode : Integer;ãbeginã Assign(Executable, GetExecutableName);ã {$I-}ã Reset(Executable, 1);ã ErrorCode := IOResult;ãã if ErrorCode = 0 thenã begin { seek position of header size in EXE File }ã Seek(Executable, 8);ã ErrorCode := IOResult;ã end; { seek header }ãã if ErrorCode = 0 thenã begin { read header size in EXE File }ã BlockRead(Executable, HeaderSize, SizeOf(HeaderSize));ã ErrorCode := IOResult;ã end; { read header }ãã if ErrorCode = 0 thenã begin { seek position of Object in EXE File }ã Seek(Executable,ã LongInt(16) * (HeaderSize + Seg(ObjectToWrite) - PrefixSeg) +ã Ofs(ObjectToWrite) - PrefixSize);ã ErrorCode := IOResult;ã end; { Seek Object position in File }ãã if ErrorCode = 0 thenã begin { Write new passWord in EXE File }ã BlockWrite(Executable, ObjectToWrite, ObjectSize);ã ErrorCode := IOResult;ã end; { Write new passWord }ãã Close(Executable);ã WriteToExecutable := ErrorCode;ããend; { Function WriteToExecutable }ããend. { Unit WritExec }ã 37 09-26-9309:01ALL MARTIN RICHARDSON Produce DOS Error MessageIMPORT 18 o"s {*****************************************************************************ã * Function ...... ErrorMsg()ã * Purpose ....... To produce a DOS error message based on the error codeã * Parameters .... ErrorCode DOS error codeã * Returns ....... Error message assosiated with passed codeã * Notes ......... Uses function ITOSã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION ErrorMsg( ErrorCode: INTEGER ): STRING;ãBEGINã CASE ErrorCode OFã 0: ErrorMsg := 'No Error';ã 2: ErrorMsg := 'File Not Found';ã 3: ErrorMsg := 'Path Not Found';ã 4: ErrorMsg := 'Too Many Open Files';ã 5: ErrorMsg := 'File Access Denied';ã 6: ErrorMsg := 'Invalid File Handle';ã 12: ErrorMsg := 'Invalid File Access Code';ã 15: ErrorMsg := 'Invalid Drive Number';ã 16: ErrorMsg := 'Cannot Remove Current Directory';ã 17: ErrorMsg := 'Cannot Rename Across Drives';ã 18: ErrorMsg := 'File access error';ã 100: ErrorMsg := 'Disk Read Error';ã 101: ErrorMsg := 'Disk Write Error';ã 102: ErrorMsg := 'File Not Assigned';ã 103: ErrorMsg := 'File Not Open';ã 104: ErrorMsg := 'File Not Open For Input';ã 105: ErrorMsg := 'File Not Open For Output';ã 106: ErrorMsg := 'Invalid Numeric Format';ã 150: ErrorMsg := 'Disk Is Write-Protected';ã 151: ErrorMsg := 'Unknown Unit';ã 152: ErrorMsg := 'Drive Not Ready';ã 153: ErrorMsg := 'Unknown Command';ã 154: ErrorMsg := 'CRC Error In Data';ã 155: ErrorMsg := 'Bad Drive Request Structure Length';ã 156: ErrorMsg := 'Disk Seek Error';ã 157: ErrorMsg := 'Unknown Media Type';ã 158: ErrorMsg := 'Sector Not Found';ã 159: ErrorMsg := 'Printer Out Of Paper';ã 160: ErrorMsg := 'Device Write Fault';ã 161: ErrorMsg := 'Device Read Fault';ã 162: ErrorMsg := 'Hardware Failure';ã ELSE ErrorMsg := 'Error Number: ' + ITOS( ErrorCode, 0 );ã END; { CASE }ãEND;ãã 38 09-26-9309:17ALL MARTIN RICHARDSON Get GREATER of Integers IMPORT 7 o" {*****************************************************************************ã * Function ...... MaxI()ã * Purpose ....... To return the greater of two integersã * Parameters .... nNum1, nNum2 The integers to compareã * Returns ....... The greater of nNum1 and nNum2ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... September 30, 1992ã *****************************************************************************}ãFUNCTION MaxI( nNum1, nNum2: LONGINT ): LONGINT; ASSEMBLER;ãASMã MOV AX, WORD PTR nNum1[0]ã MOV DX, WORD PTR nNum1[2]ã CMP DX, WORD PTR nNum2[2]ã JNLE @@2ã JL @@1ãã CMP AX, WORD PTR nNum2[0]ã JA @@2ãã@@1: MOV AX, WORD PTR nNum2[0]ã MOV DX, WORD PTR nNum2[2]ã@@2:ãEND;ã 39 09-26-9309:17ALL MARTIN RICHARDSON Get SMALLER of Integers IMPORT 7 o" {*****************************************************************************ã * Function ...... MinI()ã * Purpose ....... To return the lesser of two integersã * Parameters .... nNum1, nNum2 The integers to compareã * Returns ....... The lesser of nNum1 and nNum2ã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... September 30, 1992ã *****************************************************************************}ãFUNCTION MinI( nNum1, nNum2: LONGINT ): LONGINT; ASSEMBLER;ãASMã MOV AX, WORD PTR nNum1[0]ã MOV DX, WORD PTR nNum1[2]ã CMP DX, WORD PTR nNum2[2]ã JL @@2ã JNLE @@1ãã CMP AX, WORD PTR nNum2[0]ã JB @@2ãã@@1: MOV AX, WORD PTR nNum2[0]ã MOV DX, WORD PTR nNum2[2]ã@@2:ãEND;ã 40 09-26-9309:24ALL MARTIN RICHARDSON Generate RANDOM Number IMPORT 6 o"ã {*****************************************************************************ã * Function ...... RND()ã * Purpose ....... To generate a random numberã * Parameters .... i Max value for number rangeã * Returns ....... A random number between 1 and iã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ã{ FUNCTION to generate a random number between 1 and i }ãFUNCTION RND( i: LONGINT ): LONGINT;ãBEGINã RND := RANDOM( i ) + 1;ãEND;ãã 41 09-26-9309:25ALL MARTIN RICHARDSON Convert REAL to INTEGER IMPORT 7 o" {*****************************************************************************ã * Function ...... RTOI()ã * Purpose ....... To convert a real to an integerã * Parameters .... RealNum Real type numberã * Returns ....... The integer part of RealNumã * Notes ......... Simply truncates the decimalsã * . Uses function Leftã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION RTOI( RealNum: REAL ): LONGINT;ãVARã s: STRING;ã l: LONGINT;ã i: INTEGER;ãBEGINã STR( RealNum:17:2, s );ã s := Left( s, LENGTH(s) - 3 );ã VAL( s, l, i );ã RTOI := l;ãEND;ãã 42 09-26-9309:28ALL MARTIN RICHARDSON Convert STRING to INTEGERIMPORT 6 o" {*****************************************************************************ã * Function ...... STOI()ã * Purpose ....... To convert a string to an integerã * Parameters .... cNum String to convert to integer formatã * Returns ....... cNum as a numeric integerã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION STOI( cNum: STRING ): LONGINT;ãVARã c: INTEGER;ã i: LONGINT;ãBEGINã VAL( cNum, i, c );ã STOI := i;ãEND;ãã 43 09-26-9310:51ALL DAVID DANIEL ANDERSON Queit Noisy programs IMPORT 76 oP (*ãFrom: DAVID DANIEL ANDERSON Refer#: NONEãSubj: QUIET USING BLOCKREADã*)ããuses dos ;ãconstã bufsize = 16384;ã progdata = 'QUIET- Free DOS utility: quiets noisy programs.';ã{!} progdat2 =ã'V1.00: August 27, 1993. (c) 1993 by David Daniel Anderson - Reign Ware.';ã{!} usage =ã 'Usage: QUIET noisy_prog {will OVERWRITE the file - use a backup!!!}';ã outname = 'o$_$_$$!.DDA';ã tmpname = 't$_$_$$!.DDA';ãtypeã buffer = array [1..bufsize] of char;ãvarã buf : buffer ;ã infile,ã outfile : file ;ã bytesread,ã byteswritten : word ;ãã nextchar : char ;ãã checknext,ã extra_char,ã lastbyte : boolean ;ãã fdt : longint ;ãã dirinfo : searchrec ; { contains filespec info. }ã spath : pathstr ; { source file path, }ã sdir : dirstr ; { directory, }ã sname : namestr ; { name, }ã sext : extstr ; { extension. }ã sfn, dfn, tfn : string [64]; { Source/ Dest/ Temp FileName, including dir }ã filesdone : array [1..512] of string [64]; { table of each dir+name }ã done : boolean ; { done is used so a file is not processed twice }ã { used with the array "filesdone" because a bug }ã { (in DOS I think) causes files to be selected }ã { based on FAT placement, rather than name when }ã { wildcards are implemented. The BUG allows }ã { files to be done repeatedly, every time they }ã { are encountered. }ãã i, nmdone : word ; { i is a counter, }ã { nmdone is number of files wrapped }ãããprocedure showhelp ( errornum : byte );ãvarã message : string [80];ãbeginã writeln ( progdata );ã writeln ( progdat2 );ã writeln ;ã writeln ( usage );ã writeln ;ã {!} { all of the case messages got reformatted }ã case errornum ofã 1 : message :=ã'you must specify -exactly- one filespec (wildcards are OK).';ã 2 : message :=ã'could not open the "noisy" file: ' + sfn + ' (may be read-only).';ã 3 : message :=ã'could not open the temp file (does ' + outname + ' already exist?).';ã 4 : message :=ã'the blockread procedure failed ( error reading "noisy" file: ' + sfn + '.';ã 5 : message :=ã'rename procedure failed, "quiet" file is ' + outname + '.';ã 6 : message :=ã'original file was read only, is renamed to ' + tmpname + '.';ã 7 : message :=ã'you cannot just specify a path, add "*.*" or "\*.*" for all files.';ã 8 : message :=ã'could not find any matching files.';ã end;ã writeln ( 'ERROR: (#',errornum,') - ', message );ã halt ( errornum );ãend;ãprocedure openfiles(var ofl, nfl : file; name1, name2 : string);ãbeginã{$i-}ã assign ( ofl, name1 );ã reset ( ofl,1 );ã if ioresult <> 0 thenã showhelp (2); { unable to open ??? }ãã assign ( nfl, name2 );ã reset ( nfl );ã if ( ioresult <> 0 ) then begin { if file does -NOT- exist }ã rewrite ( nfl,1 ); { yet, it is save to proceed }ã if ioresult <> 0 then { unable to open ??? }ã showhelp (3) ;ã endã elseã showhelp (3) ;ã{$i+}ãend;ãã{!} procedure quietbufã ( var bufr : buffer; var chknext : boolean ; var noises : word );ãconstã noisea = 'æ';ã noiseb = 'a';ã NOPChar = '';ãvarã bf_indx : word ;ãbeginã for bf_indx := 1 to ( sizeof ( bufr ) - 1 ) doã if ( ( bufr [ bf_indx ] = noisea ) andã ( bufr [ bf_indx +1 ] = noiseb ) ) then beginãã noises := noises + 1 ;ã bufr [ bf_indx ] := NOPChar;ã bufr [ bf_indx +1 ] := NOPChar;ã end;ã chknext := ( bufr [ sizeof ( bufr ) ] = noisea );ãend;ããprocedure quietfile ( var infile, outfile : file );ãvarã noises : word ;ãbeginã noises := 0;ã repeatã{$i-} blockread ( infile, buf, bufsize, bytesread ); {$i+}ã if ioresult <> 0 thenã showhelp (4) ;ã quietbuf ( buf, checknext, noises );ãã if ( checknext and ( not eof ( infile ))) then beginã blockread ( infile, nextchar, 1 );ã extra_char := true ;ã if nextchar = 'a' then beginã noises := noises + 1 ;ã buf [ sizeof ( buf ) ] := '';ã nextchar := '';ã end;ã endã else extra_char := false ;ãã blockwrite ( outfile, buf, bytesread, byteswritten );ã if extra_char thenã blockwrite ( outfile, nextchar, 1 );ã lastbyte := (( bytesread = 0 ) or ( bytesread <> byteswritten ));ã until lastbyte ;ã writeln ( noises, ' noises found.' );ãend;ããbegin { MAIN }ã if paramcount <> 1 then showhelp (1);ã nmdone := 1; { initialize number done to one since }ã { count is incremented after process ends }ãã for i := 1 to 512 do { initialize array }ã filesdone[i] := ''; { (I'm not sure if this is needed) }ãã spath := paramstr (1); { source path is first parameter }ãã fsplit ( fexpand (spath),sdir,sname,sext); { break up path into components }ã if (sname = '') then { - but quit if only a path and no }ã showhelp(7); { name is given }ãã findfirst (spath, archive, dirinfo); { find the first match of filespec }ã if doserror <> 0 thenã showhelp(8);ãã while doserror = 0 do { process all specified files }ã beginã sfn := sdir+dirinfo.name; { should have dir info so we are not }ã { confused with current directory (?) }ã { IS needed for dest and temp filenames }ãã done := false; { initialize for each "new" file found }ã for i := 1 to 512 doã if sfn = filesdone[i] then { check entire array to see if we }ã done := true; { have done this file already }ãã if not done then begin { if not, then }ã filesdone[nmdone] := sfn; { say we have now }ã dfn := sdir+outname; { give both dest and }ã tfn := sdir+tmpname; { and temp files unique names }ãã openfiles ( infile, outfile, sfn, dfn );ã write ( 'Quieting ', sfn, ', ' );ã quietfile ( infile, outfile );ãã getftime ( infile, fdt );ã setftime ( outfile, fdt );ãã close (infile); { close in }ã close (outfile); { and out files }ãã{i-}ã rename ( infile, tfn ); { rename in to temp and then }ã if ioresult <> 0 thenã showhelp (5);ã rename ( outfile, sfn ); { out to in, thereby SWITCHING }ã erase ( infile ); { in with out so we can erase in (!) }ã if ioresult <> 0 thenã showhelp (6);ã{$i+}ã nmdone := nmdone + 1; { increment number processed }ã end; { if not done }ã findnext(dirinfo); { go to next (until no more) }ã end; { while }ãend.ããã QUIETã Free DOS utility: quiets noisy programsã Version 1.00 - August 27, 1993ã (c) 1993ã byã David Daniel Andersonã Reign WareããããããQUIET quiets noisy programs, by replacing certain noisemaking programãcodes.ããWARNING!!! QUIET OVERWRITES THE INPUT FILE, SO MAKE SURE THAT YOUãEITHER WORK ON A -COPY- OF YOUR FILE(S) OR YOU KNOW WHAT YOU AREãDOING BEFORE YOU START.ããUsage: QUIET noisy_progããExamples:ãã QUIET hangman.comã QUIET *.exeã QUIET pac*.*ã QUIET d:\games\fire.comããQUIET needs one and only one parameter on the command line: the fileãto be silenced. By using wildcards (* and ?), multiple files can beãprocessed in one pass. (See the DOS manual for wildcard info.)ããQUIET will maintain the original date and time of the file(s).ããã How it works:ããQUIET simply replaces the two-byte sequence: æa with: ãIn hex, that is: E6 61 and: 90 90.ãIn decimal it is: 230 97 and: 144 144.ããThe E6 61 code is simply an instruction to activate the speaker, andãthe 90 90 code is simply an instruction to do nothing.ããã Possible complications/ reasons for failure:ãã1) Some programs check themselves, and will not work at all if theyãhave been changed.ãã2) Many programs make noise by other methods, and will not be silenced.ãã3) If the file was read-only, it cannot be processed.ãã4) Some virus detectors will complain if you try this on a file whichãyou have told the watch dog program to monitor.ããNote: other errors are mentioned by the program when it encounters them.ãã---ã þ SLMR 2.1a þã þ RNET 2.00m: ILink: Channel 1(R) þ Cambridge, MA þ 617-354-7077ã 44 11-02-9304:49ALL MAYNARD PHILBROOK ARRAY Pointer in ASM IMPORT 8 o`F {ãMAYNARD PHILBROOKãã>> I've never had to do this, so I'm not sure, but can't you just pass aã>> pointer to the array? eg.ã>> typeã>> DorkArray = Array[0..255] of Byte;ã>> varã>> Dork : ^DorkArray;ã>ã> but what exactly do I declare in the assembly procedure to get thsesã> values?ã}ãASmã Mov Word AX, [Dork];ã Mov Word BX, [Dork+2];ã Mov ES, BX;ã Mov BX, AX;ã { Now ES:BX } {equal the same value as Dork}ã Mov Byte AL, [ES:BX]; {Get the first byte of Dork into AL. }ã Mov Byte AL, [ES:BX+1]; {Get the Secoce Byte of Dork into al.}ã Mov Word SI, 00;ã Mov AL, [ES:BX+SI]; {also do this.}ã Inc SI;ã Mov AL {ES:BX+SI]; Ect//ã { Another way to load up a poiter }ã LES Dowrd BX, [Dork]; { This is simpler way of defining a piiner.ã 45 11-02-9304:55ALL RANDALL ELTON DING Maze Generator IMPORT 96 oÕå {ã[email protected] (Randall Elton Ding)ããThis is really for Allen who earlier in the month asked about generatingãa maze in pascal. It may not really be the fastest, but I know ofãno other way which is faster. Check it out, it lets you try to moveãthru the maze, when you give up it shows you the way. It has variableãdifficulty and size too.ããThis was origionally written in Apple][ 6502 machine language, I portedãit over to pascal a few years later.ã}ãã(* Big Mind Over Mazeã maze generator and solverã created by Randy Dingã July 16,1983 *)ãã{$R-} { range checking }ããprogram makemaze;ããusesã crt, graph;ããconstã screenwidth = 640;ã screenheight = 350;ã minblockwidth = 2;ã maxx = 200; { [3 * maxx * maxy] must be less than 65520 (memory segment) }ã maxy = 109; { here maxx/maxy about equil to screenwidth/screenheight }ã flistsize = 5000; { flist size (fnum max, about 1/3 of maxx * maxy) }ãã background = black;ã gridcolor = green;ã solvecolor = white;ãã rightdir = $01;ã updir = $02;ã leftdir = $04;ã downdir = $08;ãã unused = $00; { cell types used as flag bits }ã frontier = $10;ã reserved = $20;ã tree = $30;ãããtypeã frec = recordã column, row : byte;ã end;ã farr = array [1..flistsize] of frec;ãã cellrec = recordã point : word; { pointer to flist record }ã flags : byte;ã end;ã cellarr = array [1..maxx,1..maxy] of cellrec;ãã {ã one byte per cell, flag bits...ãã 0: right, 1 = barrier removedã 1: top "ã 2: left "ã 3: bottom "ã 5,4: 0,0 = unused cell typeã 0,1 = frontier "ã 1,1 = tree "ã 1,0 = reserved "ã 6: (not used)ã 7: solve path, 1 = this cell part of solve pathã }ãããvarã flist : farr; { list of frontier cells in random order }ã cell : ^cellarr; { pointers and flags, on heap }ã fnum,ã width,ã height,ã blockwidth,ã halfblock,ã maxrun : word;ã runset : byte;ã ch : char;ããprocedure initbgi;ãvarã grdriver,ã grmode,ã errcode : integer;ãbeginã grdriver := DETECT;ã grmode := EGAhi;ã initgraph(grdriver, grmode, 'e:\bp\bgi');ã errcode:= graphresult;ã if errcode <> grok thenã beginã writeln('Graphics error: ', grapherrormsg(errcode));ã halt(1);ã end;ãend;ãããfunction adjust(var x, y : word; d : byte) : boolean;ãbegin { take x,y to next cell in direction d }ã case d of { returns false if new x,y is off grid }ã rightdir:ã beginã inc (x);ã adjust:= x <= width;ã end;ãã updir:ã beginã dec (y);ã adjust:= y > 0;ã end;ãã leftdir:ã beginã dec (x);ã adjust:= x > 0;ã end;ãã downdir:ã beginã inc (y);ã adjust:= y <= height;ã end;ã end;ãend;ãããprocedure remove(x, y : word); { remove a frontier cell from flist }ãvarã i : word; { done by moving last entry in flist into it's place }ãbeginã i := cell^[x,y].point; { old pointer }ã with flist[fnum] doã cell^[column,row].point := i; { move pointer }ã flist[i] := flist[fnum]; { move data }ã dec(fnum); { one less to worry about }ãend;ãããprocedure add(x, y : word; d : byte); { add a frontier cell to flist }ãvarã i : byte;ãbeginã i := cell^[x,y].flags;ã case i and $30 of { check cell type }ã unused :ã beginã cell^[x,y].flags := i or frontier; { change to frontier cell }ã inc(fnum); { have one more to worry about }ã if fnum > flistsize thenã begin { flist overflow error! }ã dispose(cell); { clean up memory }ã closegraph;ã writeln('flist overflow! - To correct, increase "flistsize"');ã write('hit return to halt program ');ã readln;ã halt(1); { exit program }ã end;ã with flist[fnum] doã begin { copy data into last entry of flist }ã column := x;ã row := y;ã end;ã cell^[x,y].point := fnum; { make the pointer point to the new cell }ã runset := runset or d; { indicate that a cell in direction d was }ã end; { added to the flist }ãã frontier : runset := runset or d; { allready in flist }ã end;ãend;ãããprocedure addfront(x, y : word); { change all unused cells around this }ãvar { base cell to frontier cells }ã j, k : word;ã d : byte;ãbeginã remove(x, y); { first remove base cell from flist, it is now }ã runset := 0; { part of the tree }ã cell^[x,y].flags := cell^[x,y].flags or tree; { change to tree cell }ã d := $01; { look in all four directions- $01,$02,$04,$08 }ã while d <= $08 doã beginã j := x;ã k := y;ã if adjust(j, k, d) thenã add(j, k, d); { add only if still in bounds }ã d := d shl 1; { try next direction }ã end;ãend;ãããprocedure remline(x, y : word; d : byte); { erase line connecting two blocks }ãbeginã setcolor(background);ã x := (x - 1) * blockwidth;ã y := (y - 1) * blockwidth;ã case d ofã rightdir : line (x + blockwidth, y + 1, x + blockwidth, y + blockwidth - 1);ã updir : line (x + 1, y, x + blockwidth - 1, y);ã leftdir : line (x, y + 1, x, y + blockwidth - 1);ã downdir : line (x + 1, y + blockwidth, x + blockwidth - 1, y + blockwidth);ã end;ãend;ããã{ erase line and update flags to indicate the barrier has been removed }ãprocedure rembar(x, y : word; d : byte);ãvarã d2 : byte;ãbeginã remline(x, y, d); { erase line }ã cell^[x,y].flags := cell^[x,y].flags or d; { show barrier removed dir. d }ã d2 := d shl 2; { shift left twice to reverse direction }ã if d2 > $08 thenã d2 := d2 shr 4; { wrap around }ã if adjust(x, y, d) then { do again from adjacent cell back to base cell }ã cell^[x,y].flags := cell^[x,y].flags or d2; { skip if out of bounds }ãend;ãããfunction randomdir : byte; { get a random direction }ãbeginã case random(4) ofã 0 : randomdir := rightdir;ã 1 : randomdir := updir;ã 2 : randomdir := leftdir;ã 3 : randomdir := downdir;ã end;ãend;ãããprocedure connect(x, y : word); { connect this new branch to the tree }ãvar { in a random direction }ã j, k : word;ã d : byte;ã found : boolean;ãbeginã found := false;ã while not found doã begin { loop until we find a tree cell to connect to }ã j := x;ã k := y;ã d := randomdir;ã if adjust(j, k, d) thenã found := cell^[j,k].flags and $30 = tree;ã end;ã rembar(x, y, d); { remove barrier connecting the cells }ãend;ãããprocedure branch(x, y : word); { make a new branch of the tree }ãvarã runnum : word;ã d : byte;ã i : boolean;ãbeginã runnum := maxrun; { max number of tree cells to add to a branch }ã connect(x, y); { first connect frontier cell to the tree }ã addfront(x, y); { convert neighboring unused cells to frontier }ã dec(runnum); { number of tree cells left to add to this branch }ã while (runnum > 0) and (fnum > 0) and (runset > 0) doã beginã repeatã d := randomdir;ã until d and runset > 0; { pick random direction to known frontier }ã rembar(x, y, d); { and make it part of the tree }ã i := adjust(x, y, d);ã addfront(x, y); { then pick up the neighboring frontier cells }ã dec(runnum);ã end;ãend;ãããprocedure drawmaze;ãvarã x, y, i : word;ãbeginã setcolor(gridcolor); { draw the grid }ã y := height * blockwidth;ã for i := 0 to width doã beginã x := i * blockwidth;ã line(x, 0, x, y);ã end;ã x := width * blockwidth;ã for i := 0 to height doã beginã y := i * blockwidth;ã line (0, y, x, y);ã end;ã fillchar(cell^, sizeof(cell^), chr(0)); { zero flags }ã fnum := 0; { number of frontier cells in flist }ã runset := 0; { directions to known frontier cells from a base cell }ã randomize;ã x := random(width) + 1; { pick random start cell }ã y := random(height) + 1;ã add(x, y, rightdir); { direction ignored }ã addfront(x, y); { start with 1 tree cell and some frontier cells }ã while (fnum > 0) doã with flist[random(fnum) + 1] doã branch(column, row);ãend;ããprocedure dot(x, y, colr : word);ãbeginã putpixel(blockwidth * x - halfblock, blockwidth * y - halfblock, colr);ãend;ããprocedure solve(x, y, endx, endy : word);ãvarã j, k : word;ã d : byte;ã i : boolean;ãbeginã d := rightdir; { starting from left side of maze going right }ã while (x <> endx) or (y <> endy) doã beginã if d = $01 thenã d := $08ã elseã d := d shr 1; { look right, hug right wall }ã while cell^[x,y].flags and d = 0 doã begin { look for an opening }ã d := d shl 1; { if no opening, turn left }ã if d > $08 thenã d := d shr 4;ã end;ã j := x;ã k := y;ã i := adjust(x, y, d); { go in that direction }ã with cell^[j,k] doã begin { turn on dot, off if we were here before }ã flags := ((((cell^[x,y].flags xor $80) xor flags) and $80) xor flags);ã if flags and $80 <> 0 thenã dot(j, k, solvecolor)ã elseã dot(j, k, background);ã end;ã end;ã dot(endx, endy, solvecolor); { dot last cell on }ãend;ããprocedure mansolve (x,y,endx,endy: word);ãvarã j, k : word;ã d : byte;ã ch : char;ãbeginã ch := ' ';ã while ((x <> endx) or (y <> endy)) and (ch <> 'X') and (ch <> #27) doã beginã dot(x, y, solvecolor); { dot man on, show where we are in maze }ã ch := upcase(readkey);ã dot(x, y, background); { dot man off after keypress }ã d := 0;ã case ch ofã #0:ã beginã ch := readkey;ã case ch ofã #72 : d := updir;ã #75 : d := leftdir;ã #77 : d := rightdir;ã #80 : d := downdir;ã end;ã end;ãã 'I' : d := updir;ã 'J' : d := leftdir;ã 'K' : d := rightdir;ã 'M' : d := downdir;ã end;ãã if d > 0 thenã beginã j := x;ã k := y; { move if no wall and still in bounds }ã if (cell^[x,y].flags and d > 0) and adjust(j, k, d) thenã beginã x := j;ã y := k;ã end;ã end;ã end;ãend;ããprocedure solvemaze;ãvarã x, y,ã endx,ã endy : word;ã ch : char;ãbeginã x := 1; { pick random start on left side wall }ã y := random(height) + 1;ã endx := width; { pick random end on right side wall }ã endy := random(height) + 1;ã remline(x, y, leftdir); { show start and end by erasing line }ã remline(endx, endy, rightdir);ã mansolve(x, y, endx, endy); { try it manually }ã solve(x, y, endx, endy); { show how when he gives up }ã while keypressed doã ch := readkey;ã ch := readkey;ãend;ãããprocedure getsize;ãvarã j, k : real;ãbeginã clrscr;ã writeln(' Mind');ã writeln(' Over');ã writeln(' Maze');ã writeln;ã writeln(' by Randy Ding');ã writeln;ã writeln('Use I,J,K,M or arrow keys to walk thru maze,');ã writeln('then hit X when you give up!');ã repeatã writeln;ã write('Maze size: ', minblockwidth, ' (hard) .. 95 (easy) ');ã readln(blockwidth);ã until (blockwidth >= minblockwidth) and (blockwidth < 96);ã writeln;ã write('Maximum branch length: 1 easy .. 50 harder, (0 unlimited) ');ã readln(maxrun);ã if maxrun <= 0 thenã maxrun := 65535; { infinite }ã j := screenwidth / blockwidth;ã k := screenheight / blockwidth;ã if j = int(j) thenã j := j - 1;ã if k = int(k) thenã k := k - 1;ã width := trunc(j);ã height := trunc(k);ã if (width > maxx) or (height > maxy) thenã beginã width := maxx;ã height := maxy;ã end;ã halfblock := blockwidth div 2;ãend;ããbeginã repeatã getsize;ã initbgi;ã new(cell); { allocate this large array on heap }ã drawmaze;ã solvemaze;ã dispose(cell);ã closegraph;ã while keypressed doã ch := readkey;ã write ('another one? ');ã ch := upcase (readkey);ã until (ch = 'N') or (ch = #27);ãend.ãã 46 11-02-9305:35ALL JON JASIUNAS Trapping Runtime Errors IMPORT 9 oj
{ãJON JASIUNASããI never use them. if a Program bombs because a disk is full, I justã> catch the run-time error in an Exit proc and report so (I/O-checkingã> must be set on, of course).ãã>I am curious, How do you go about Catching the Run-Time Error. Doesn't itã>just say Runtime Error 103 ?????:?????ããYou can catch the run-time errors by linking into the Exit chain.ãHere's a small example:ã}ããUnit ErrTrap;ããInterfaceããImplementationããVarã OldExit : Pointer;ããProcedure NewExit; Far; { MUST be far! }ãbeginã if ErrorAddr <> nil thenã beginã {-Display custom run-time error message }ã WriteLn('Fatal error #', ExitCode);ã WriteLn('Address = ', Seg(ErrorAddr^), ':', Ofs(ErrorAddr^));ã {-Cancel run-time error so you don't get the default message, too }ã ErrorAddr := nil;ã {-Zero the errorlevel }ã ExitCode := 0;ã end;ã ExitProc := OldExit;ãend;ããbeginã OldExit := ExitProc;ã ExitProc := @NewExit;ãend.ããã 47 11-02-9305:37ALL JON JASIUNAS Modify EXE Constants IMPORT 19 oÜ {ãJON JASIUNASãã>Is it possible to store variables in actual .EXE file of a TP program, insteã>of making an external config file for it? Thanks.ããSure. Make them typed constants, then modify the .EXE whenever you wantãto store a change.ã}ããtypeã tOwnerName = string[30];ã tRegCode = String[12];ããconstã OwnerName : tOwnerName = '';ã RegCode : tRegCode = '';ããbeginã WriteLn('The current owner is : ', OwnerName);ã WriteLn('The current registration code is : ', RegCode);ã WriteLn;ãã Write('Enter the new owner name: ');ã ReadLn(OwnerName);ã Write('Enter the new registration code: ');ã ReadLn(RegCode);ãã If Write2Exe(OwnerName, SizeOf(OwnerName)) <> 0 thenã WriteLn('Owner name not updated!');ãã If Write2Exe(RegCode, SizeOf(RegCode)) <> 0 thenã WriteLn('Registration code not updated!');ãend.ãã{ Here's my self mod unit: }ãã{*****************************ã * EXEMOD.PAS v1.0 *ã * *ã * General purose .EXE *ã * self-modifying routines *ã *****************************ãã1992-93 HyperDrive SoftwareãReleased into the public domain.}ãã{$S-,R-,D-,I-}ã{$IFOPT O+}ã {$F+}ã{$ENDIF}ããunit ExeMod;ããinterfaceããvarã ExeName : String;ããfunction Write2Exe(var Data2Write; DataSize : Word) : Integer;ããimplementationããfunction Write2Exe(var Data2Write; DataSize : Word): Integer;ãconstã PrefixSize = 256;ãvarã ExeFile : File;ã HeaderSize : Word;ã IoError : Integer;ãbeginã Assign(ExeFile, ExeName);ã Reset(ExeFile, 1);ã IoError := IOResult;ãã If IoError = 0 thenã {-Seek position of header size in EXE File }ã beginã Seek(ExeFile, 8);ã IoError := IOResult;ã end; { If }ãã If IoError = 0 thenã {-Read header size in EXE File }ã beginã BlockRead(ExeFile, HeaderSize, Sizeof(HeaderSize));ã IoError := IOResult;ã end;ãã If IoError = 0 thenã {-Seek position of Data in EXE File }ã beginã Seek(ExeFile, LongInt(16) * (HeaderSize + Seg(Data2Write) - PrefixSeg) +ã IoError := IOResult;ã end;ãã If IoError = 0 thenã {-Write new Data to EXE File }ã beginã BlockWrite(ExeFile, Data2Write, DataSize);ã IoError := IOResult;ã end;ãã Close(ExeFile);ã Write2Exe := IoError;ãend;ããbeginã ExeName := ParamStr(0);ãend.ãã 48 11-02-9305:39ALL WILBERT VAN LEIJEN Export data from OBJ fileIMPORT 11 otå {ãWILBERT VAN LEIJENãã> I want to pass its address to an external .obj procedure so I can setã> DS:SI to it... how do I do this? I know how to do this sort of think if Iã> use the tp60 built in asmm thingy, and I know that I can pass values usingã> arg likeããYou cannot export data from an .OBJ file to a Pascal program. The linkerãcannot handle with public identifiers other than in a segment of class CODE,ãalas.ããStore the data in a File of Byte (DORK.BIN), convert it with BINOBJ to DORK.OBJã(suggested identifier: Procedure DorkData), link it to your program.ã}ããProcedure DorkData; External;ã{$L DORK.OBJ }ããTypeã TDork = Array[0..255] of Byte;ã PDork = ^TDork;ããVarã Dork : PDork;ã i : Integer;ããBeginã Dork := @DorkData;ã For i := Low(TDork) to High(TDork) Doã Write(Dork^[i] : 4);ãend.ãã{ If you want to use assembler to access DorkData: }ããASMã CLDã PUSH DSã PUSH CS { Using "LDS SI, DorkData" will not work! }ã POP DSã LEA SI, DorkData { DS:SI points to DorkData }ã MOV CX, Type(TDork) { = 256 }ã @1: LODSB { TDork(DorkData[256-CX]) is now in AL }ã { other code }ã LOOP @1ã POP DSãend;ã 49 11-02-9305:50ALL KAI ROHRBACHER HACKING in Pascal IMPORT 11 o¨ {ãKAI ROHRBACHERããI'm looking For a way to tell BorlandPascal that an allocated _data_ãblock should now be treated as an executable routine (in Protected Mode).ãHere is a little example to show the problem; it runs w/o problems inãReal Mode, but results in a GP-fault (despite the use of the alias-selector!):ã}ããProgram SelfModify;ããConstã AnzNOPs = 10;ããTypeã TTestProc = Procedure;ããVarã code : Pointer;ã Run : TTestProc;ã pb : ^Byte;ã pw : ^Word Absolute pb;ã i : LongInt;ããbeginã GetMem(code, AnzNOPs + 7); {7 Bytes For proc header & end}ã pb := code; {pb = ^start of routine to build}ãã pb^ := $55;ã INC(pb); {push bp}ã pw^ := $E589;ã INC(pw); {mov bp,sp}ã For i := 1 to AnzNOPs DOã beginã pb^ := $90;ã INC(pb); {nop's}ã end;ã pb^ := $5D;ã INC(pb); {pop bp}ã pb^ := $CA;ã INC(pb);ã pw^ := $0000; {retf 0}ãã {$IFDEF DPMI}ã WriteLN('Protected Mode');ã code:= Ptr(Seg(code) + SelectorInc, Ofs(code)); {alias-selector}ã {$else}ã WriteLN('Real Mode');ã {$endIF}ãã Run := TTestProc(code); {that's a Type-cast!}ã Run; {call routine}ãã FreeMem(code, AnzNOPs + 7);ã WriteLN('Alive and kicking!');ãend.ã 50 11-02-9306:02ALL MARTIN LARSEN BREAK and CONTINUE IMPORT 3 oy {ãMARTIN LARSENããThere are at least two nice features in BP7: BREAK and CONTINUE:ã}ããRepeatã Inc(Count);ã if Odd(Count) then Continue; { Go to start of loop }ã if Count = 10 then Break; { Go to sentence just after loop }ãUntil False;ã 51 11-02-9310:29ALL BOB SWART OPTIMIZE.PAS IMPORT 31 o¯; {ãBOB SWARTãã> Does anybody have any tips on optimizing TP Programs?ãWhat kind of optimization? Speed or Size? Optimizing For one may not be theãsame as optimizing For the other...ãã> but now it has grown quite large (anybody want it? :), and I'd likeã> to shrink it.ãAh, so optimizing For size! Minimizing data space, code space (and stack/heapãusage as well).ãã> I've gotten it from 40k down to 29k after a lot of work, but that isã> still too big.ãDo you want to turn it into a TSR?ãã> Does anyone know of any common optimization techniques that would work?ãDo you use BAsm code or plain Pascal?ãã> For instance, if inc(IntVar, amt) is more efficient (code size wise)ã> than IntVar := IntVar + amt;ãYes, try dumpprog (by our beloved moderator) on those two statements:ããtest.pas#4: i := i + 4;ã 0000:000F A15000 MOV AX,[DS: i(0050)]ã 0000:0012 050400 ADD AX,0004ã 0000:0015 A35000 MOV [DS: i(0050)],AXããIt takes 9 Bytes For "i := i + 4;"ããtest.pas#5: Inc(i,4);ã 0000:0018 8306500004 ADD [Word DS:+i(+0050)],+04ããIt takes only 5 Bytes to do "Inc(i,4);" (and it is also faster!!)ããã> That's the kind of thing that I'm looking for.ãWell Brian, currently I'm working on a whole BOOK about 'Borland PascalãPerformance Optimization' (about 250-pages, english, early '94 ). In my book,ãthe process op Program optimization is divided into four steps: 1. finding theãbottle-necks in your Program, 2. using better datastructures & algorithms, 3.ãusing more efficient language Constructs, and 4. using BAsm code and InLineãmacros. There will be a whole chapter devoted to 'optimization techniques forãProgram size', but I will say a few Words here For you:ããMost of the times optimization is a matter of SPEED vs. SIZE. if you want theãsmallest code, then prepare let the Program do some more work. Eliminate bigãlook-up tables (if you use any), use small, simple datastructures (that oftenãimply not-so-efficient algorithms), do not use more Units than the ones youãAbsolutely need. Even then, try to code the routines from those Units yourselfã(avoid any and all overhead from those Units). If, For example, you need aãReadKey-like Function, don't use the Crt Unit, but implement your own ReadKeyãFunction like this:ãã{$A-,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X+}ã{.$DEFINE Crt}ãProgram test;ã{$IFDEF Crt}ã{ Code size: 3056ã Data size: 690ã .EXE size: 3232ã}ãUses Crt;ã{$else}ã{ Code size: 1504 --> 1552 Bytes lessã Data size: 672 --> 18 Bytes lessã .EXE size: 1680 --> 1552 Bytes lessã}ãConstã ScanCode : Byte = 0;ã _ReadKey : Byte = $00;ããFunction ReadKey : Char; Assembler;ãAsmã mov AL, ScanCode { check old ScanCode }ã mov ScanCode,0 { empty old ScanCode }ã or AL, AL { AL = 0? }ã jne @end { no: return ScanCode }ã xor AH, AH { AH := 0 }ã int $16 { read Character }ã or AL, AL { AL = 0? }ã jne @end { no: simple Character }ã mov ScanCode, AH { yes: extended Character }ã @end:ãend;ã{$endIF}ããVarã t : Char;ãbeginã t := ReadKey;ãend.ããThe resulting code is 1552 Bytes less when using your own ReadKey instead ofãthe Crt Unit. This is mainly due to the initalization code of the Crt Unit, ofãcourse, but even For you 1.5 Kb is about 5% code size...ããAs you can see above, if you try to push your code to the limit, you MUST useãBAsm or InLine macros. The Turbo/Borland Pascal compilers simply do notãgenerate code as efficient as a good Programmer can do.ããFinally, if you can't wait Until early '94, an article about Borland PascalãPerformance Optimization will be published in an opcoming issue of PCãTechniques. if you want more information about the book send me some netmail orãWrite to the address below. I'll send you some information on paper.ãã 52 11-02-9310:32ALL ANDY MCFARLAND Dealing Poker IMPORT 5 oxß { ANDY MCFARLAND }ããVarã pick : Array [1..52] of Byte;ã i, n,ã temp : Word;ããbeginã { start With an ordered deck }ã For i := 1 to 52 doã pick[i] := i ;ãã For i:= 52 downto 2 doã begin { [i+1..52] has been shuffled }ã { pick any card in the unshuffled part of the deck }ã n := random(i) + 1 ; { N in [1..i] }ã temp := pick[n] ; { exchange pick[i] pick[n] }ã pick[n] := pick[i] ;ã pick[i] := temp ;ã end ;ãend;ã 53 11-02-9310:33ALL SEAN PALMER POKER Again IMPORT 13 og {ãSEAN PALMERãã> I'm trying to Write a small Poker game For a grade in my Highã> School Pascal Class. I set the deck up as an Array of String'sã> (example: Deck: Array[1..52] of String)ã> And then filled the Array With somthing like: Deck[1]:='2 ofã> Diamonds'; I may have started wrongly, but I need a way to "Shuffle"ã> the deck. I could probably read them into the Array Randomly, orã> could I keep them in a logical order in the Array and shuffle theã> Array itself? Let me know if you have any ideas concerning myã> problem maybe you could post some code For me.ããThere are probably better ways to set up the data structure, such as:ã}ããTypeã tCardVal = (Two, Three, Four, Five, Six, Seven,ã Eight, Nine, Ten, Jack, Queen, King, Ace);ã tCardSuit = (Spades, Diamonds, Hearts, Clubs);ãã tCard = Recordã val : tCardVal;ã suit : tCardSuit;ã end;ããConstã valStrings : Array [tCardVal] of String[5] =ã ('Two', 'Three', 'Four', 'Five', 'Six', 'Seven',ã 'Eight', 'Nine', 'Ten', 'Jack', 'Queen', 'King', 'Ace');ã suitStrings : Array [tCardSuit] of String[8] =ã ('Spades', 'Diamonds', 'Hearts', 'Clubs');ããVarã deck : Array [0..51] of tCard;ãã{ after initializing the deck, you could shuffle With a Procedure like this: }ããfor i := 300 + random(50) downto 0 doãbeginã posn := random(51);ã tempCard := deck[posn];ã deck[posn] := deck[posn + 1];ã deck[posn + 1] := tempCard;ãend;ãã{ãThis might be better if it swapped two randomly-picked cards, would shuffleãbetter... }ã 54 11-02-9310:33ALL LEE BARKER POKER Again and Again IMPORT 15 oö {ãLEE BARKERãã³ I'm trying to Write a small Poker game For a grade in myã³ High School Pascal Class.ããWhile the Array of Strings will work, it is a lot of overheadãfor what you want to do. It is also difficult to do the scoring.ãThe following is a small piece of code I posted a year or twoãago when someone asked a similar question. Offered as a studyãguide For your homework.ã}ããConstã Limit = 5; { Minimum cards before reshuffle }ã MaxDecks = 1; { Number of decks in use }ã NbrCards = MaxDecks * 52;ã Cardvalue : Array [0..12] of String[5] =ã ('Ace','Two','Three','Four','Five','Six','Seven',ã 'Eight','Nine','Ten','Jack','Queen','King');ã Suit : Array [0..3] of String[8] =ã ('Hearts','Clubs','Diamonds','Spades');ããTypeã DeckOfCards = Array [0..Pred(NbrCards)] of Byte;ããVarã Count,ã NextCard : Integer;ã Cards : DeckOfCards;ããProcedure shuffle;ãVarã i, j,ã k, n : Integer;ãbeginã randomize;ã j := 0; { New Decks }ã For i := 0 to pred(NbrCards) doã beginã Cards[i] := lo(j);ã inc(j);ã if j > 51 thenã j := 0;ã end;ã For j := 1 to 3 do { why not ? }ã For i := 0 to pred(NbrCards) doã begin { swap }ã n := random(NbrCards);ã k := Cards[n];ã Cards[n] := Cards[i];ã Cards[i] := k;ã end;ã NextCard := NbrCards;ãend;ããFunction CardDealt : Byte;ãbeginã Dec(NextCard);ã CardDealt := Cards[NextCard];ãend;ããProcedure ShowCard(b : Byte);ãVarã c, s : Integer;ãbeginã c := b mod 13;ã s := b div 13;ã Writeln('The ', Cardvalue[c], ' of ', Suit[s]);ãend;ããbeginã Shuffle;ã Writeln('< The deck is shuffled >');ã { if NextCard <= Limit then shuffle }ã For Count := 1 to 5 doã ShowCard(CardDealt);ã Readln;ãend.ã 55 11-02-9318:41ALL VARIOUS AUTHORS ROMAN numbers IMPORT 46 o(A }ãFrom: BRIAN PAPEãSubj: YEAR ( ROMAN )ãThis is from last semester's computer bowl. Only problem is that itãconverts from Roman to Arabic. :)ãã LCCC Programming Teamãã East Central College Computer Bowlãã 03-21-93ãã "Computer Killers"ã Brian Papeã Brian Grammerã Mike Lazarã Christy Reedã Matt Hayesã Coach Steve Banjavcicãã Program #2-3ã Time to Completion: 3:47ã}ããprogram roman;ãUSES PRINTER;ãconstã num = 'IVXLCDM';ã value : array[1..7] of integer = (1,5,10,50,100,500,1000);ãvarã i : byte;ã s : string;ã sum : integer;ãbeginã assign(lst,'');rewrite(lst);ã writeln('Enter the Roman Numerals: ');ã readln(s);ã i := length(s);ã while (i>=1) doã beginã if i > 1 thenã beginã if pos(s[i],num) <= (pos(s[i-1],num)) thenã beginã sum := sum + value[pos(s[i],num)];ã dec(i);ã endã elseã beginã sum := sum + value[pos(s[i],num)] - value[pos(s[i-1],num)];ã dec(i,2);ã end; { else }ã endã elseã beginã sum := sum + value[pos(s[1],num)];ã dec(i);ã end; { else }ã end; { while }ã WRITELN(LST);ã writeln(LST,'Roman numeral: ',s);ã writeln(LST,'Arabic value: ',sum);ãend. { }ãã{*ã *ã * ROMAN.C - Converts integers to Roman numeralsã *ã * Written by: Jim Walshã *ã * Compiler : Microsoft QuickC v2.5ã *ã * This Program Is Released To The Public Domainã *ã * Additional Comments:ã *ã * Ported to TP v6.0 by Daniel Prosser.ã *}ããVARã Value, DValue, Error : INTEGER;ã Roman : STRING[80];ããBEGINã Roman := '';ãã IF ParamCount = 2 THENã VAL(ParamStr(1), Value, Error)ã ELSEã BEGINã Write ('Enter an integer value: ');ã ReadLn (Value);ã END; { ELSE }ãã DValue := Value;ãã WHILE Value >= 1000 DOã BEGINã Roman := Roman + 'M';ã Value := Value - 1000;ã END; { WHILE }ãã IF Value >= 900 THENã BEGINã Roman := Roman + 'CM';ã Value := Value - 900;ã END; { IF }ãã WHILE Value >= 500 DOã BEGINã Roman := Roman + 'D';ã Value := Value - 500;ã END; { WHILE }ãã IF Value >= 400 THENã BEGINã Roman := Roman + 'CD';ã Value := Value - 400;ã END; { IF }ãã WHILE Value >= 100 DOã BEGINã Roman := Roman + 'C';ã Value := Value - 100;ã END; { WHILE }ãã IF Value >= 90 THENã BEGINã Roman := Roman + 'XC';ã Value := Value - 90;ã END; { IF }ãã WHILE Value >= 50 DOã BEGINã Roman := Roman + 'L';ã Value := Value - 50;ã END; { WHILE }ãã IF Value >= 40 THENã BEGINã Roman := Roman + 'XL';ã Value := Value - 40;ã END; { WHILE }ãã WHILE Value >= 10 DOã BEGINã Roman := Roman + 'X';ã Value := Value - 10;ã END; { WHILE }ãã IF Value >= 9 THENã BEGINã Roman := Roman + 'IX';ã Value := Value - 9;ã END; { IF }ãã WHILE Value >= 5 DOã BEGINã Roman := Roman + 'V';ã Value := Value - 5;ã END; { WHILE }ãã IF Value >= 4 THENã BEGINã Roman := Roman + 'IV';ã Value := Value - 4;ã END; { IF }ããã WHILE Value > 0 DOã BEGINã Roman := Roman + 'I';ã DEC (Value);ã END; { WHILE }ãã WriteLn (DValue,' = ', Roman);ãEND.ãã{--------------------- Begin of function -----------------------------}ãããFunction Roman (Number: Integer): String;ã{ Converts Number to the Roman format.ã If (Number < 1) Or (Number > 3999), the returned string will be empty!ã}ãVarã TempStr : String; { Temporary storage for the result string }ãBeginã TempStr := '';ã If (Number > 0) And (Number < 4000) Thenã Beginã { One 'M' for every 1000 }ã TempStr := Copy ('MMM', 1, Number Div 1000);ã Number := Number MOD 1000;ã If Number >= 900 Thenã { Number >= 900, so append 'CM' }ã Beginã TempStr := TempStr + 'CM';ã Number := Number - 900;ã Endã Elseã { Number < 900 }ã Beginã If Number >= 500 Thenã { Number >= 500, so append 'D' }ã Beginã TempStr := TempStr + 'D';ã Number := Number - 500;ã Endã Elseã If Number >= 400 Thenã { 400 <= Number < 500, so append 'CD' }ã Beginã TempStr := TempStr + 'CD';ã Number := Number - 400;ã End;ã { Now Number < 400!!! One 'C' for every 100 }ã TempStr := TempStr + Copy ('CCC', 1, Number Div 100);ã Number := Number Mod 100;ã End;ã If Number >= 90 Thenã { Number >= 90, so append 'XC' }ã Beginã TempStr := TempStr + 'XC';ã Number := Number - 90;ã Endã Elseã { Number < 90 }ã Beginã If Number >= 50 Thenã { Number >= 50, so append 'L'}ã Beginã TempStr := TempStr + 'L';ã Number := Number - 50;ã Endã Elseã If Number >= 40 Thenã { 40 <= Number < 50, so append 'XL' }ã Beginã TempStr := TempStr + 'XL';ã Number := Number - 40;ã End;ã { Now Number < 40!!! One 'X' for every 10 }ã TempStr := TempStr + Copy ('XXX', 1, Number Div 10);ã Number := Number Mod 10;ã End;ã If Number = 9 Thenã { Number = 9, so append 'IX' }ã Beginã TempStr := TempStr + 'IX';ã Endã Elseã { Number < 9 }ã Beginã If Number >= 5 Thenã { Number >= 5, so append 'V' }ã Beginã TempStr := TempStr + 'V';ã Number := Number - 5;ã Endã Elseã If Number = 4 Thenã { Number = 4, so append 'IV' }ã Beginã TempStr := TempStr + 'IV';ã Number := Number - 4;ã End;ã { Now Number < 4!!! One 'I' for every 1 }ã TempStr := TempStr + Copy ('III', 1, Number);ã End;ã End;ã Roman := TempStr;ãEnd;ãã 56 11-21-9309:41ALL SWAG SUPPORT TEAM MAXMIN Bytes/Integers IMPORT 22 o¨' {$R-}ãUNIT MaxMin;ã(**) INTERFACE (**)ã FUNCTION MaxS(A, B : ShortInt) : ShortInt;ã FUNCTION MinS(A, B : ShortInt) : ShortInt;ã FUNCTION MaxB(A, B : Byte) : Byte;ã FUNCTION MinB(A, B : Byte) : Byte;ã FUNCTION MaxI(A, B : Integer) : Integer;ã FUNCTION MinI(A, B : Integer) : Integer;ã FUNCTION MaxW(A, B : Word) : Word;ã FUNCTION MinW(A, B : Word) : Word;ã FUNCTION MaxL(A, B : LongInt) : LongInt;ã FUNCTION MinL(A, B : LongInt) : LongInt;ã FUNCTION MaxU(A, B : LongInt) : LongInt;ã FUNCTION MinU(A, B : LongInt) : LongInt;ãã(**) IMPLEMENTATION (**)ã FUNCTION MaxS(A, B : ShortInt) : ShortInt; Assembler;ã ASMã MOV AL, Aã CMP AL, Bã JGE @noã MOV AL, Bã @no:ã END;ãã FUNCTION MinS(A, B : ShortInt) : ShortInt; Assembler;ã ASMã MOV AL, Aã CMP AL, Bã JLE @noã MOV AL, Bã @no:ã END;ãã FUNCTION MaxB(A, B : Byte) : Byte; Assembler;ã ASMã MOV AL, Aã CMP AL, Bã JAE @noã MOV AL, Bã @no:ã END;ãã FUNCTION MinB(A, B : Byte) : Byte; Assembler;ã ASMã MOV AL, Aã CMP AL, Bã JBE @noã MOV AL, Bã @no:ã END;ãã FUNCTION MaxI(A, B : Integer) : Integer; Assembler;ã ASMã MOV AX, Aã CMP AX, Bã JGE @noã MOV AX, Bã @no:ã END;ãã FUNCTION MinI(A, B : Integer) : Integer; Assembler;ã ASMã MOV AX, Aã CMP AX, Bã JLE @noã MOV AX, Bã @no:ã END;ãã FUNCTION MaxW(A, B : Word) : Word; Assembler;ã ASMã MOV AX, Aã CMP AX, Bã JAE @noã MOV AX, Bã @no:ã END;ãã FUNCTION MinW(A, B : Word) : Word; Assembler;ã ASMã MOV AX, Aã CMP AX, Bã JBE @noã MOV AX, Bã @no:ã END;ãã FUNCTION MaxL(A, B : LongInt) : LongInt; Assembler;ã ASMã MOV DX, Word(A+2)ã MOV AX, Word(A)ã CMP DX, Word(B+2)ã JL @yesã JG @noã CMP AX, Word(B)ã JGE @noã @yes:ã MOV DX, Word(B+2)ã MOV AX, Word(B)ã @no:ã END;ãã FUNCTION MinL(A, B : LongInt) : LongInt; Assembler;ã ASMã MOV DX, Word(A+2)ã MOV AX, Word(A)ã CMP DX, Word(B+2)ã JG @yesã JL @noã CMP AX, Word(B)ã JLE @noã @yes:ã MOV DX, Word(B+2)ã MOV AX, Word(B)ã @no:ã END;ãã FUNCTION MaxU(A, B : LongInt) : LongInt; Assembler;ã ASMã MOV DX, Word(A+2)ã MOV AX, Word(A)ã CMP DX, Word(B+2)ã JB @yesã JA @noã CMP AX, Word(B)ã JAE @noã @yes:ã MOV DX, Word(B+2)ã MOV AX, Word(B)ã @no:ã END;ãã FUNCTION MinU(A, B : LongInt) : LongInt; Assembler;ã ASMã MOV DX, Word(A+2)ã MOV AX, Word(A)ã CMP DX, Word(B+2)ã JA @yesã JB @noã CMP AX, Word(B)ã JBE @noã @yes:ã MOV DX, Word(B+2)ã MOV AX, Word(B)ã @no:ã END;ãEND. 57 11-21-9309:49ALL BOB SWART UUENCODE IMPORT 34 oÌ/ {ãFrom: BOB SWARTãSubj: UUENCODE.PASãHere is my version of UUENCODE.PAS (fully compatible):ã}ãã{$IFDEF VER70}ã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}ã{$ELSE}ã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S+,V-,X-}ã{$ENDIF}ã{$M 8192,0,0}ã{ã UUEnCode 3.0ã Borland Pascal (Objects) 7.0.ã Copr. (c) 9-29-1993 DwarFools & Consultancy drs. Robert E. Swartã P.O. box 799ã 5702 NP Helmondã The Netherlandsã Code size: 4880 bytesã Data size: 1122 bytesã .EXE size: 3441 bytesã ----------------------------------------------------------------ã This program uuencodes files.ã}ããConstã SP = Byte(' ');ããTypeã TTriplet = Array[0..2] of Byte;ã TKwartet = Array[0..3] of Byte;ããvar Triplets: Array[1..15] of TTriplet;ã kwar: TKwartet;ã FileName: String[12];ã i,j: Integer;ã f: File;ã g: Text;ããã FUNCTION UpperStr(S : STRING) : STRING;ã VAR sLen : BYTE ABSOLUTE S;ã I : BYTE;ã BEGINã FOR I := 1 TO sLEN DO S := UpCase(S[i]);ã UpperStr := S;ã END;ãã procedure Triplet2Kwartet(Triplet: TTriplet; var Kwartet: TKwartet);ã var i: Integer;ã beginã Kwartet[0] := (Triplet[0] SHR 2);ã Kwartet[1] := ((Triplet[0] SHL 4) AND $30) +ã ((Triplet[1] SHR 4) AND $0F);ã Kwartet[2] := ((Triplet[1] SHL 2) AND $3C) +ã ((Triplet[2] SHR 6) AND $03);ã Kwartet[3] := (Triplet[2] AND $3F);ã for i:=0 to 3 doã beginã if Kwartet[i] = 0 then Kwartet[i] := $40;ã Inc(Kwartet[i],SP)ã endã end {Triplet2Kwartet};ãããbeginã writeln('UUEnCode 3.0 (c) 1993 DwarFools & Consultancy' +ã ', by drs. Robert E. Swart'#13#10);ã if ParamCount = 0 thenã beginã writeln('Usage: UUEnCode infile [outfile]');ã Haltã end;ã if UpperStr(ParamStr(1)) = UpperStr(ParamStr(2)) thenã beginã writeln('Error: infile = outfile');ã Halt(1)ã end;ãã Assign(f,ParamStr(1));ã FileMode := $40;ã reset(f,1);ã if IOResult <> 0 thenã beginã writeln('Error: could not open file ',ParamStr(1));ã Halt(2)ã end;ãã if ParamCount <> 2 thenã beginã FileName := ParamStr(1);ã i := Pos('.',FileName);ã if i > 0 then Delete(FileName,i,Length(FileName));ã FileName := FileName + '.UUE'ã endã else FileName := ParamStr(2);ãã if UpperStr(ParamStr(1)) = UpperStr(FileName) thenã beginã writeln('Error: input file = output file');ã Halt(1)ã end;ãã Assign(g,FileName);ã if ParamCount > 1 thenã beginã FileMode := $02;ã reset(g);ã if IOResult = 0 thenã beginã writeln('Error: file ',FileName,' already exists.');ã halt(3)ã endã end;ã rewrite(g);ã if IOResult <> 0 thenã beginã writeln('Error: could not create file ',FileName);ã Halt(4)ã end;ãã writeln(g,'begin 0777 ',ParamStr(1));ã repeatã FillChar(Triplets,SizeOf(Triplets),#0);ã BlockRead(f,Triplets,SizeOf(Triplets),i);ã write(g,Char(SP+i));ã for j:=1 to (i+2) div 3 doã beginã Triplet2Kwartet(Triplets[j],kwar);ã write(g,Char(kwar[0]),Char(kwar[1]),Char(kwar[2]),Char(kwar[3]))ã end;ã writeln(g)ã until (i < SizeOf(Triplets));ã writeln(g,'end');ã close(f);ã close(g);ãã if ParamCount > 1 thenã writeln('UUEnCoded file ',FileName,' created.');ã writelnãend.ããããThe basic scheme is to break groups of 3 eight bit characters (24 bits) into 4ãsix bit characters and then add 32 (a space) to each six bit character whichãmaps it into the readily transmittable character. Another way of phrasing thisãis to say that the encoded 6 bit characters are mapped into the set:ãã !"#$%&'()*+,-./012356789:;<=>[email protected][\]^_ããfor transmission over communications lines.ããAs some transmission mechanisms compress or remove spaces, spaces are changedãinto back-quote characters (a 96). (A better scheme might be to use a bias ofã33 so the space is not created, but this is not done.)ããThe advantage of this over just hex encoding is that it put in 6 bits of signalãper byte, instead of just 4. The target is to get the smallest uncompressedãsize, since the assumption is that you've already compressed as much redundancyãas possible out of the original.ãã 58 11-21-9309:50ALL BOB SWART UUDCODE.PAS IMPORT 30 oâ¿ {ãFrom: BOB SWARTãSubj: UUDECODE.PASãHere is my version of UUDECODE.PAS (also fully compatible):ã}ãã{$IFDEF VER70}ã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S+,T-,V-,X-}ã{$ELSE}ã{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S+,V-,X-}ã{$ENDIF}ã{$M 8192,0,0}ã{ã UUDeCode 3.0ã Borland Pascal (Objects) 7.0.ã Copr. (c) 9-29-1993 DwarFools & Consultancy drs. Robert E. Swartã P.O. box 799ã 5702 NP Helmondã The Netherlandsã Code size: 4832 bytesã Data size: 1330 bytesã .EXE size: 3337 bytesã ----------------------------------------------------------------ã This program uudecodes files.ã}ããConstã SP = Byte(' ');ãã Typeã TTriplet = Array[0..2] of Byte;ã TKwartet = Array[0..3] of Byte;ããvar f: Text;ã g: File of Byte;ã FileName: String[12];ã Buffer: String;ã Kwartets: recordã lengte: Byte;ã aantal: Byte;ã kwart: Array[1..64] of TKwartet;ã end absolute Buffer;ã Trip: TTriplet;ã i: Integer;ãã FUNCTION UpperStr(S : STRING) : STRING;ã VAR sLen : BYTE ABSOLUTE S;ã I : BYTE;ã BEGINã FOR I := 1 TO sLEN DO S := UpCase(S[i]);ã UpperStr := S;ã END;ãã procedure Kwartet2Triplet(Kwartet: TKwartet; var Triplet: TTriplet);ã beginã Triplet[0] := ((Kwartet[0] - SP) SHL 2) +ã (((Kwartet[1] - SP) AND $30) SHR 4);ã Triplet[1] := (((Kwartet[1] - SP) AND $0F) SHL 4) +ã (((Kwartet[2] - SP) AND $3C) SHR 2);ã Triplet[2] := (((Kwartet[2] - SP) AND $03) SHL 6) +ã ((Kwartet[3] - SP) AND $3F)ã end {Kwartet2Triplet};ãããbeginã writeln('UUDeCode 3.1 (c) 1993 DwarFools & Consultancy' +ã ', by drs. Robert E. Swart'#13#10);ã if ParamCount = 0 thenã beginã writeln('Usage: UUDeCode infile [outfile]');ã Haltã end;ãã if UpperStr(ParamStr(1)) = UpperStr(ParamStr(2)) thenã beginã writeln('Error: infile = outfile');ã Halt(1)ã end;ãã Assign(f,ParamStr(1));ã FileMode := $40;ã reset(f);ã if IOResult <> 0 thenã beginã writeln('Error: could not open file ',ParamStr(1));ã Halt(2)ã end;ã repeatã readln(f,Buffer) { skip }ã until eof(f) or (Copy(Buffer,1,5) = 'begin');ã if Buffer[11] = #32 then FileName := Copy(Buffer,12,12)ã elseã if Buffer[10] = #32 then FileName := Copy(Buffer,11,12)ã else FileName := ParamStr(2);ã {$IFDEF DEBUG}ã writeln(FileName);ã {$ENDIF}ãã if UpperStr(ParamStr(1)) = UpperStr(FileName) thenã beginã writeln('Error: input file = output file');ã Halt(1)ã end;ãã Assign(g,FileName);ã if ParamCount > 1 thenã beginã FileMode := $02;ã reset(g);ã if IOResult = 0 thenã beginã writeln('Error: file ',FileName,' already exists.');ã Halt(3)ã endã end;ã rewrite(g);ã if IOResult <> 0 thenã beginã writeln('Error: could not create file ',FileName);ã Halt(4)ã end;ãã while (not eof(f)) and (Buffer <> 'end') doã beginã FillChar(Buffer,SizeOf(Buffer),#32);ã readln(f,Buffer);ã if Buffer <> 'end' thenã beginã for i:=1 to (Kwartets.aantal-32) div 3 doã beginã Kwartet2Triplet(Kwartets.kwart[i],Trip);ã write(g,Trip[0],Trip[1],Trip[2])ã end;ã if ((Kwartets.aantal-32) mod 3) > 0 thenã beginã Kwartet2Triplet(Kwartets.kwart[i+1],Trip);ã for i:=1 to ((Kwartets.aantal-32) mod 3) do write(g,Trip[i-1])ã endã endã end;ã close(f);ã close(g);ãã if ParamCount > 1 thenã writeln('UUDeCoded file ',FileName,' created.');ã writelnãend.ã 59 11-26-9316:59ALL PAUL ROBINSON UU Encode files IMPORT 27 oÅ {ã Pascal program to UUDECODE files which were processedã with UUENCODE. Or it will DECODE files which wereã processed by ENCODEãã Paul Robinson [email protected]ã Tansin A. Darcos & Companyã June 26, 1993ã}ããvar inf,outf:text;ã open:boolean;ã ch:char;ã buflen,tag:char;ã tagfiller:array[1..80] of char;ã buf:string[80] absolute buflen;ã tag3:array[1..3] of char absolute tag;ã tag6:array[1..6] of char absolute tag;ã outfn:string[80];ã bp,n:integer;ããfunction dec(c:char):byte;ãbeginã dec := (ord(c) - ord(' ')) and 63ãend;ããprocedure short(msg:string);ãbeginã writeln(msg);ã close(inf);ã if open thenã close(outf);ã halt(1);ãend;ãããprocedure skip;ãbeginã while buf[bp] = ' ' doã beginã bp := bp+1;ã if bp>=length(buf) thenã short('Error 01 Bad begin line');ã end;ã while buf[bp] <> ' ' doã beginã bp := bp+1;ã if bp>=length(buf) thenã short('Error 02 Bad begin line');ã end;ã while buf[bp] = ' ' doã beginã bp := bp+1;ã if bp>=length(buf) thenã short('Error 03 Bad begin line');ã end;ã while (buf[bp] <> ' ') doã beginã outfn := outfn+buf[bp];ã bp := bp+1;ã end;ãend;ãããã{ output a group of 3 bytes (4 input characters).ã the input chars are pointed to by bp.ã n is used to tell us not to output all of themã at the end of the file.ã}ããprocedure outdec(bp,n:integer);ãvar c1,c2,c3:byte;ãbeginã c1 := (DEC(buf[bp]) shl 2) or (dec(buf[bp+1]) shr 4);ã c2 := (dec(buf[bp+1]) shl 4) or (dec(buf[bp+2]) shr 2);ã c3 := (dec(buf[bp+2]) shl 6) or dec(buf[bp+3]);ã if n >= 1 thenã write(outf,chr(c1));ã if n >= 2 thenã write(outf,chr(c2));ã if n >= 3 thenã write(outf,chr(c3));ãend;ããprocedure decode;ãbeginã if eof(inf) thenã short('Premature EOF');ã repeatã readln(inf,buf);ã if length(buf)>0 thenã beginã n := dec(buf[1]);ã if n > 0 thenã beginã bp := 2;ã while n>0 doã beginã outdec(bp, n);ã bp := bp+4;ã n := n-3;ã end;ã end;ã end;ã until length(buf)<2;ãend;ããããbeginã if (paramcount <1) or ((paramcount >=1) and (paramstr(1)='/?')) thenã beginã writeln('Pascal UUDECODER by Paul Robinson - [email protected]');ã writeln('Usage: DECODE filename');ã halt(0);ã end;ã assign(inf,paramstr(1));ã open := false;ãã {$I-} reset(inf); {$I+}ã if IORESULT <> 0 thenã short('File '+paramstr(1)+' cannot be opened.');ã if not eof(inf) thenã readln(inf,buf)ã elseã short('Empty file');ã while tag6 <> 'begin ' doã if not eof(inf) thenã readln(inf,buf)ã elseã short('No begin line');ã bp := 6;ã buf := buf+' ';ãã{ã format is 'begin nnn filename'ã skip spaces before the nnnã skip the nnnã skip spaces after the nnnã}ã skip;ã assign(outf,outfn);ã{$I-} rewrite(outf); {$I+}ã if IORESULT = 0 thenã open := trueã elseã short('Cannot create file '+outfn);ãã decode;ã readln(inf,buf);ã if tag3 <> 'end' thenã short('Warning: no end line');ã close(inf);ã if open thenã close(outf);ãend.ã 60 11-26-9317:11ALL SWAG SUPPORT GROUP Trap Floating point Errs IMPORT 43 o2 {ã There was a discussion about how to trap floating point errorsãin TP. Here is the solution that traps any kind of run-timeãerrors. The idea is not mine. I saw it in a russian book about TPãand OOP.ãã The idea is quite simple. Instead of trying to trap all kind ofãerrors, we can let TP to do the job for us. Whenever TP stopsãexecution of the program ( because of a run time error or justãbecause the program stops in a natural way ) it executes theãdefault procedure of exit : ExitProc. Then TP checks the status ofãtwo variables from the SYSTEM unit : ErrorAddr and ExitCode. Ifãthere was a run time error then ErrorAddr is not NIL and ExitCodeãcontaines the run time error code. Otherwise ExitCode containes theãerrorlevel that will be set for DOS and ErrorAddr is NIL.ãFortunatly we can easily redefine the ExitProc, and thus toãovertake the control from TP. The problem is that we got to be ableãto get back or to jump to any point of the program ( even to jumpãinside a procedure / function). The author of the book claimed thatãhe took his routines from Turbo Professional.ãã Well, there are two files you are gonna need. Save the first oneãas JUMP.PAS Compile it as a unit. The second one is a short programãthat shows how to use it. It asks for two numbers, divides theãfirst by the second and takes a natural logarithm of the result.ãTry to divide by zero, logarithm of a negative number. Try enteringãletters instead of numbers and see how the program recovers.ãã The trapping works fine under Windows/Dos. To run it withãWINDOWS recompile the JUMP unit for Windows target. Then add WinCrtãto the Uses statement and remove Mark/Release lines ( because thereãis no Mark/Release for Windows ).ã}ããUnit Jump;ãInterfaceãType JumpRecord = Recordã SpReg,ã BpReg : Word;ã JmpPt : Pointer;ã end;ããProcedure SetJump ( Var JumpDest : JumpRecord );ã{Storing SP,BP and the address}ãinline(ã $5F/ {pop di }ã $07/ {pop es }ã $26/$89/$25/ {mov es:[di],sp }ã $26/$89/$6D/$02/ {mov es:[di+2],bp }ã $E8/$00/$00/ {call null }ã {null: }ã $58/ {pop ax }ã $05/$0C/$00/ {add ax,12 }ã $26/$89/$45/$04/ {mov es:[di+4],ax }ã $26/$8C/$4D/$06); {mov es:[di+6],cs }ã {next: }ããProcedure LongJump ( Var JumpDest : JumpRecord );ã{Restore everything and jump}ãinline(ã $5F/ {pop di }ã $07/ {pop es }ã $26/$8B/$25/ {mov sp,es:[di] }ã $26/$8B/$6D/$02/ {mov bp,es:[di+2] }ã $26/$FF/$6D/$04); {jmp far es:[di+4]}ããImplementationãEnd.ããã------------------------------try.pas------------------------------ããProgram Try;ãUses Jump; {Uses Jump,WinCrt;}ãVarã OldExit : Pointer;ã MyAddr : JumpRecord;ã MyHeap : Pointer;ãã a1,a2,ã a3,a4 : real;ããã{$F+}ãProcedure MyExit;ã{You can add your error handler here}ãBeginã If ErrorAddr<>Nil Then Beginã case ExitCode ofã 106 : Writeln('Invalid numeric format');ã 200 : Writeln('Division by zero');ã 205 : Writeln('Floating point overflow');ã 206 : Writeln('Floating point underflow');ã 207 : Writeln('Invalid floating point operation');ã else Writeln('Hmmm... How did you do that ?');ã end;ã ErrorAddr:=Nil;ã LongJump(MyAddr);ã end;ã ExitProc:=OldExit;ãEnd;ã{$F-}ããBeginã OldExit:=ExitProc;ã Mark(MyHeap); {Just an example of how to restore the heap }ã {Actually we don't have to do that in }ã {this program, because we dont use heap }ã {at all. But anyway here it goes }ã {Don't forget to remove when compiling this }ã {for Windows }ããã SetJump(MyAddr); {We'll get back here whenever a run time }ã {error occurs }ã {This line should always be before }ã { ExitProc:=MyExit; }ã {Don't ask me why... It's much easier for me}ã {to follow the rule then to understand it :)}ã ExitProc:=@MyExit;ãã Release(MyHeap); {restoring the heap after a run time error }ã {Remove this if you are compiling it for }ã {Windows }ãã {Try entering whatever you want at the }ã {prompt. It should trap every runtime error}ã {you could possibly get. }ã Repeatã Writeln;ã Write('Enter a number a1=');ã Readln(a1);ã Write('Enter a number a2=');ã Readln(a2);ã a3:=a1/a2;ã Writeln('a1/a2=',a3:10:5);ã a4:=ln(a3);ã Writeln('ln(a1/a2)=',a4:10:5);ã until a3=1;ãend.ã 61 11-26-9317:37ALL SWAG SUPPORT GROUP Pick Unit; Select Choice IMPORT 88 o
à (********************************************************)ã(******************** PICK.PAS **************************)ã(******* the pick unit; to select menu choice *******)ããUnit Pick;ããinterfaceãã{1} Function ScreenChar : Char; {return the char at the cursor}ã{2} Procedure BlockCursor; {give us a block cursor; TP6 & 7 only}ã{3} Procedure NormalCursor; {restore cursor to normal; TP6 & 7 only}ãã{4} Function PickByte(Left, Top, Bottom : Byte) : Byte;ã {return the number of the item chosen as a byte, orã return ZERO if ESCape is pressed}ãã{5} Function PickChar(Left, Top, Bottom : Byte) : Char;ã {return the character at the cursor when ENTER is pressed}ããã{ãNotes: for "Pick" functionsã One returns a Byte and the other returns a Char - use oneã or the other;ãã Parameters:ã Left = the left side of the menu list (left side of window+1)ã Top = the top of the menu list (top of window+1)ã Bottom = the bottom of the menu list; (bottom of window-1)ã}ããimplementationããusesãdos,ãcrt,ãkeyb;ãã{-----------------------------------------------------}ãFunction PickByte(Left,Top,Bottom : byte) : Byte;ã{return the number of the item chosen as a byte, orãreturn ZERO if ESCape is pressed}ããVarãx,y,x1,y1 : byte;ãch : char;ãint,total : byte;ããbeginã PickByte := 0; {default to ZERO}ã total := (Bottom - Top)+1; {total number of items in list}ã x1 := WhereX; y1 := WhereY; {save the original location}ãã x := Left; y := Top;ã BlockCursor; {give us a block cursor}ãã GotoXy(x, y);ãã int := 1;ãã Repeatã Ch := GetKey;ãã Case Ch ofã LeftArrow, UpArrow : {move up}ã beginã If y = Top thenã beginã y := Bottom;ã int := total;ã endã elseã beginã Dec(y);ã dec(int);ã end;ãã GotoXy(x,y);ã end; {leftarrow}ãã RightArrow, DownArrow : {move down}ã beginã If y = Bottom thenã beginã y := Top;ã int := 1;ã endã elseã beginã Inc(y);ã inc(int);ã end;ã GotoXy(x,y);ã end; {rightarrow}ãã PgUp, Home : {go to top of list}ã beginã y := Top;ã int := 1;ã GotoXy(x,y);ã end;ãã PgDn, EndKey : {go to bottom of list}ã beginã y := Bottom;ã int := total;ã GotoXy(x,y);ã end;ãã #13 : PickByte := int; {return position of choice in the array}ã End; {Case Ch}ãã Until (ch = #27) or (ch = #13); {loop until ESCape or ENTER}ãã GotoXY(x1,y1); {return to original location}ã NormalCursor; {Restore the cursor}ãend;ã{---------------------------------------------}ããFunction PickChar(Left, Top,Bottom : byte) : Char;ã{return the character at the cursor when ENTER is pressed}ããVarãx,y,x1,y1 : byte;ãch : char;ããbeginã PickChar := #27;ã x1 := WhereX; y1 := WhereY;ã x := Left; y := Top;ãã BlockCursor; {give us a block cursor}ã GotoXy(x,y);ãã Repeatã Ch := GetKey;ã Case Ch ofã LeftArrow, UpArrow :ã beginã If y = Top then y := Bottom else Dec(y);ã GotoXy(x,y);ã end; {leftarrow}ãã RightArrow, DownArrow :ã beginã If y = Bottom then y := Top else Inc(y);ã GotoXy(x,y);ã end; {leftarrow}ãã PgUp, Home :ã beginã y := Top;ã GotoXy(x,y);ã end;ãã PgDn, EndKey :ã beginã y := Bottom;ã GotoXy(x,y);ã end;ãã #13 : PickChar := ScreenChar; {return the char under the cursor}ã End; {Case Ch}ãã Until (ch = #27) or (ch = #13);ã GotoXY(x1,y1);ã NormalCursor; {give us a block cursor}ããend;ã{-----------------------------------------------}ãã{----------------------------------------}ãFunction ScreenChar : Char; {return the character at the cursor}ãVarãR : Registers;ãbeginã Fillchar(R, SizeOf(R), 0);ã R.AH := 8;ã R.BH := 0;ã Intr($10, R);ã ScreenChar := Chr(R.AL);ãend;ã{--------------------------------------------------}ããã{---------------------------------}ãProcedure NormalCursor; {restore cursor to normal; TP6 & 7 only}ãBEGINã asmã mov ah,1ã mov ch,5 { / You will want to fool around with these two}ã mov cl,6 { \ numbers to get the cursor you want}ã int $10ã END;ãEND;ãã{--------------------------------}ãProcedure BlockCursor; {give us a block cursor; TP6 & 7 only}ãBEGINã asmã mov ah,1ã mov ch,5 { / You will want to fool around with these two}ã mov cl,8 { \ numbers to get the cursor you want; (1=big)}ã int $10ã END;ãEND;ã{-------------------------------------}ããEnd.ãã{----------------- end of PICK.PAS --------------------}ããããã(********************************************************)ã(******************** KEYB.PAS **************************)ã(******* the keyboard unit; for GetKey() function *******)ããUnit Keyb;ããInterfaceããUses Crt;ããConstã F1 = #187;ã F2 = #188;ã F3 = #189;ã F4 = #190;ã F5 = #191;ã F6 = #192;ã F7 = #193;ã F8 = #194;ã F9 = #195;ã F10 = #196;ãã ALTF1 = #232;ã ALTF2 = #233;ã ALTF3 = #234;ã ALTF4 = #235;ã ALTF5 = #236;ã ALTF6 = #237;ã ALTF7 = #238;ã ALTF8 = #239;ã ALTF9 = #240;ã ALTF10 = #241;ãã CTRLF1 = #222;ã CTRLF2 = #223;ã CTRLF3 = #224;ã CTRLF4 = #225;ã CTRLF5 = #226;ã CTRLF6 = #227;ã CTRLF7 = #228;ã CTRLF8 = #229;ã CTRLF9 = #230;ã CTRLF10 = #231;ãã SHFTF1 = #212;ã SHFTF2 = #213;ã SHFTF3 = #214;ã SHFTF4 = #215;ã SHFTF5 = #216;ã SHFTF6 = #217;ã SHFTF7 = #218;ã SHFTF8 = #219;ã SHFTF9 = #220;ã SHFTF10 = #221;ãã UPARROW = #200;ã RIGHTARROW = #205;ã LEFTARROW = #203;ã DOWNARROW = #208;ãã HOME = #199;ã PGUP = #201;ã ENDKEY = #207;ã PGDN = #209;ã INS = #210;ã DEL = #211;ã TAB = #9;ã ESC = #27;ã ENTER = #13;ã SYSREQ = #183;ã CTRLMINUS = #31;ã SPACE = #32;ã CTRL2 = #129;ã CTRL6 = #30;ã BACKSPACE = #8;ã BS = #8; {2 NAMES FOR BACKSPACE}ãã CTRLBACKSLASH = #28;ã CTRLLEFTBRACKET = #27;ã CTRLRIGHTBRACKET = #29;ã CTRLBACKSPACE = #127;ã CTRLBS = #127;ãã ALTA = #158;ã ALTB = #176;ã ALTC = #174;ã ALTD = #160;ã ALTE = #146;ã ALTF = #161;ã ALTG = #162;ã ALTH = #163;ã ALTI = #151;ã ALTJ = #164;ã ALTK = #165;ã ALTL = #166;ã ALTM = #178;ã ALTN = #177;ã ALTO = #152;ã ALTP = #153;ã ALTQ = #144;ã ALTR = #147;ã ALTS = #159;ã ALTT = #148;ã ALTU = #150;ã ALTV = #175;ã ALTW = #145;ã ALTX = #173;ã ALTY = #149;ã ALTZ = #172;ãã CTRLA = #1;ã CTRLB = #2;ã CTRLC = #3;ã CTRLD = #4;ã CTRLE = #5;ã CTRLF = #6;ã CTRLG = #7;ã CTRLH = #8;ã CTRLI = #9;ã CTRLJ = #10;ã CTRLK = #11;ã CTRLL = #12;ã CTRLM = #13;ã CTRLN = #14;ã CTRLO = #15;ã CTRLP = #16;ã CTRLQ = #17;ã CTRLR = #18;ã CTRLS = #19;ã CTRLT = #20;ã CTRLU = #21;ã CTRLV = #22;ã CTRLW = #23;ã CTRLX = #24;ã CTRLY = #25;ã CTRLZ = #26;ãã ALT1 = #248;ã ALT2 = #249;ã ALT3 = #250;ã ALT4 = #251;ã ALT5 = #252;ã ALT6 = #253;ã ALT7 = #254;ã ALT8 = #255;ã ALT9 = #167;ã ALT0 = #168;ãã ALTMINUS = #169;ã ALTEQ = #170;ã SHIFTTAB = #143;ããFunction GetKey : Char;ãprocedure unGetKey(C : char);ãprocedure FlushKbd;ãprocedure flushBuffer;ããconstã hasPushedChar : boolean = false;ããimplementationãvarã pushedChar : char;ããã(******************************************************************************ã* FlushKbd *ã******************************************************************************)ãprocedure FlushKbd;ãvarã C : char;ãbeginã hasPushedChar := False;ã while (KeyPressed) doã C := GetKey;ãend; {flushKbd}ãã(******************************************************************************ã* flushBuffer *ã* Same as above, but if key was pushed by eventMgr, know about it !! *ã******************************************************************************)ãprocedure flushBuffer;ãvarã b : boolean;ãbeginã b := hasPushedChar;ã flushKbd;ã hasPushedChar := b;ãend; {flushBuffer}ããã(******************************************************************************ã* unGetKey *ã* UnGetKey will put one character back in the input buffer. Push-back buffer *ã* can contain only one character. *ã* To avoid problems DO NOT CALL UNGETKEY WITHOUT FIRST CALLING GETKEY. If two *ã* characters are pushed, the first is discarded. *ã******************************************************************************)ãprocedure unGetKey;ãbeginã hasPushedChar := True;ã pushedChar := c;ãend; {unGetKey}ãã(******************************************************************************ã* GetKey *ã******************************************************************************)ãfunction GetKey : Char;ãvarã c : Char;ãBeginã if (hasPushedChar) then beginã GetKey := pushedChar;ã hasPushedChar := False;ã exit;ã end;ã c := ReadKey;ã if (Ord(c) = 0) then Beginã c := ReadKey;ã if c in [#128,#129,#130,#131]ã then c := chr(ord(c) + 39)ã else c := chr(ord(c) + 128); {map to suit keyboard constants}ã End;ã GetKey := c; {return keyboard (my..) code }ãEnd; {getKey}ããEnd.ã{--------------- End of KEYB.PAS ---------------}ããã(********************************************************)ã(************************** TEST.PAS ********************)ã(*************** to test the PICK unit ******************)ã(*************** quit by pressing ESCape ****************)ããProgram Test;ããuses crt,pick;ãã{--------------- test program -----------------}ãconstãmax = 6;ãs : array[1..max] of string[18] =ã(ã'1. Number One ',ã'2. Number Two ',ã'3. Number Three ',ã'4. Number Four ',ã'5. Number Five ',ã'6. Number Six ');ããvarãi : byte;ãx : byte;ãch : char;ãj : byte;ããbeginã clrscr;ã x := 10; {left side of the list}ããã {------------------------- test using PickByte() ----------------}ã for i := 1 to max doã begin {display the list of menu items}ã j := i+5; {start from row 6}ã gotoxy(x,j);ã writeln(s[i]);ã end;ãã i := j;ã repeatã {ch := choice(x,1,i);}ã j := pickbyte(x,6,i);ãã gotoxy(15,22);ã writeln('You chose ',j);ã until j = 0; {until Escape}ãã {------------------------- test using PickChar() ----------------}ã ClrScr;ãã ch := 'A';ã for i := 1 to max doã beginã s[i][1] := Ch; {change numbers to letters in menu list}ã Inc(Ch);ã end;ãã for i := 1 to max doã begin {display the list of menu items}ã gotoxy(x,i); {start from row 1}ã writeln(s[i]);ã end;ãã repeatã ch := PickChar(x,1,i);ã gotoxy(15,22);ã writeln('You chose ',ch);ã until ch = #27; {until Escape}ããend.ã{------------------------ end of TEST.PAS ---------------------------}ã 62 11-26-9317:39ALL SWAG SUPPORT GROUP RANDOM Numbers IMPORT 17 oZ ãinterfaceããprocedure InitRandomGenerator(InitValue : longint);ãfunction Random:real;ããimplementationãtypeã Lint = recordã a,b,c,d : word;ã end;ãvarã yWertZufall : Lint;ã Modul : Lint;ã Faktor : integer;ãprocedure LintMUL(var p1: Lint; p2: integer);ãbeginã asmã mov cx,4ã les di,p1ã xor bx,bxã cldã @mull: mov ax,es:[di]ã mov dx,p2ã mul dxã add ax,bxã adc dx,0ã mov bx,dxã stoswã loop @mullã end;ãend;ãprocedure LintSub(var p1, p2: Lint);ãvarã result : longint;ã carry : word;ãbeginã result := p1.a;ã dec(result, p2.a);ã if result < 0 thenã beginã carry := 1;ã inc(result, 65536);ã endã elseã carry := 0;ã p1.a := result;ã result := p1.b;ã dec(result, carry);ã dec(result, p2.b);ã if result < 0 thenã beginã carry := 1;ã inc(result, 65536);ã endã elseã carry := 0;ã p1.b := result;ã result := p1.c;ã dec(result, carry);ã dec(result, p2.c);ã if result < 0 thenã beginã carry := 1;ã inc(result, 65536);ã endã elseã carry := 0;ã p1.c := result;ã dec(p1.d, carry);ã dec(p1.d, p2.d);ãend;ããprocedure InitRandomGenerator(InitValue : longint);ãbeginã with yWertZufall doã beginã b := InitWert div 65536;ã a := InitWert - b*65536;ã c := 0;ã d := 0;ã end;ãend; (* InitRandomGenerator *)ããfunction Random:real;ãvarã Wert : longint;ãbeginã LintMul(yWertZufall , Faktor);ã if yWertZufall.b >32767 thenã LintSub(yWertZufall,Modul);ãã Wert := 2*yWertZufall.c + 65536*yWertZufall.b+yWertZufall.a;ã with yWertZufall do beginã d := 0;ã c := 0;ã b := Wert shr 16;ã a := Wert - (b*65536);ã end;ã Zufall := Wert / 2147483647;ããend; (* Zufall *)ãbeginã with yWertZufall doã beginã a := 0;ã b := 0;ã c := 0;ã d := 0;ã end;ã Faktor := 16807;ã with Modul doã beginã a := 65535;ã b := 32767;ã c := 0;ã d := 0;ã end;ãend. (* _Zufall *)ã 63 11-26-9317:48ALL STEVE SCHAFER TRAP8087 Errors IMPORT 16 o|Ð {ãHere is how to trap errors on the 80X87. I am not sure yet how it works withãthe FP emulation library, but if you have a math coprocessor, you can trapãany FP exceptions:ã}ãã{$N+,E+}ãprogram FloatTest;ã{ compliments of Steve Schafer, Compuserve address 76711, 522 }ãconstã feInvalidOp = $01;ã feDenormalOp = $02;ã feZeroDivide = $04;ã feOverFlow = $08;ã feUnderFlow = $10;ã fePrecision = $20;ããprocedure SetFpuExceptionMask (MaskBits: Byte); assembler;ã{ Masks floating point exceptions so that they won't cause a crash }ãvarã Temp: word;ãasmã fstcw Tempã fwaitã mov ax, Tempã and al, $F0ã or al, MaskBitsã mov Temp, axã fldcw Tempã fwaitãend;ããfunction GetFpuStatus: Byte; assembler;ã{ determines the status of a previous FP operation }ãvarã Temp: word;ãasmã fstsw Tempã fwaitã mov ax, Tempãend;ããprocedure WriteStatus(Status: Byte);ã{ This procedure is not necessary, it simply illustrates how to determineã what happenend }ãbeginã if (Status and fePrecision) <> 0 then Write('P')ã else Write('-');ã if (Status and feUnderflow) <> 0 then Write('U')ã else Write('-');ã if (Status and feOverflow) <> 0 then Write('O')ã else Write('-');ã if (Status and feZeroDivide) <> 0 then Write('Z')ã else Write('-');ã if (Status and feDenormalOp) <> 0 then Write('D')ã else Write('-');ã if (Status and feInvalidOp) <> 0 then Write('I')ã else Write('-');ãend;ããvarã X,Y: Single;ããbeginã SetFPUExceptionMask (feInvalidOp + feDenormalOp + feZeroDivideã + feOverflow + feUnderflow + fePrecision);ãã X:= -1.0;ã Y:= Sqrt(X); { Invalid Operation }ã WriteStatus(GetFPUStatus); ã Writeln(' ', Y:12, ' ', X:12);ãã X:= 0.0;ã Y:= 1.0;ã Y:= Y/X; { divide by Zero }ã WriteStatus(GetFPUStatus);ã Writeln(' ', Y:12, ' ', X:12);ãã X:= 1.0E-34;ã Y:= 1.0E-34;ã Y:= Y*X; { Underflow }ã WriteStatus(GetFPUStatus);ã Writeln(' ', Y:12, ' ', X:12);ããend.ã 64 01-27-9411:53ALL HELGE HELGESEN ASM Calls and Jumps IMPORT 8 o}$ {ã> If I make a Assembly routine in a Turbo Pascal program,ã> how can I make far jumps, calls, etc?ããHere's two procedures:ã}ããprocedure CallFar(Where : pointer); assembler;ãasmã call Whereãend;ããprocedure JmpFar(Where : pointer); inline($cb);ãã{ã> How can I make labels?ãYou can make local labels.ã}ããasmã jcxz @1ã shl ax, clã @1:ã add cx, bxã ...ãend;ã{ãBut with assembly in Pascal you can also make local variables;ã}ããprocedure Test; assembler;ãvarã MyLocalVar : word; { a variable }ãasmã mov MyLocalVar, 0 { clear contents }ãend;ãã{ã> how to discover the offset of a certain instruction?ããTo discover the offset for a variable, you might use LEAã(Load Effective Address).ã}ã LEA bx, MyLocalVar { for the above example }ã{ãWill NOT return the contents of MyLocalVar, but the offsetãwithin the stack segment to MyLocalVar.ã} 65 01-27-9411:56ALL ANDRES CVITKOVICH BP Bug IMPORT 18 oIî {ãI'm not sure if the following bug in Contains() of STDDLG.PAS has been fixedãin 7.01 (since I still don't have it) so I decided to post it.ããSTDDLG.PAS, function Contains()ã}ã{ Contains returns true if S1 contains any characters in S2 }ãfunction Contains(S1, S2 : String): Boolean; near; assembler;ãasmã PUSH DSã CLDã LDS SI, S1ã LES DI, S2ã MOV DX, DIã> INC DX { DX still pointed at len byte }ã XOR AH, AHã LODSBã MOV BX, AXã OR BX, BXã JZ @@2ã MOV AL, ES:[DI]ã XCHG AX, CXã @@1:ã PUSH CXã MOV DI, DXã LODSBã REPNE SCASBã POP CXã JE @@3ã DEC BXã JNZ @@1ã @@2:ã XOR AL, ALã JMP @@4ã @@3:ã MOV AL, 1ã @@4:ã POP DSãend;ãã{ãBUT: fixing the bug reveals another bug ããThe function is used to determine whether a filename or path contains illegalãcharacters or not. The last character in the constant "IllegalChars" is theãbackslash "\" that would have been ignored by the buggy version of Contains().ãHowever, the corrected version returns TRUE for Contains('\MYPATH\',ãIllegalChars) (as it's supposed to). Since a path name created by FSplitãnormally contains a "\" the filename is considered as FALSE by ValidFileName.ãMy solution is to add a second const named IllegalCharsFN for illegal chars inãthe filename (but legal chars in path names) currently just containing '\'.ãFurthermore, I removed space ' ' from the list of illegal characters (since itãisn't an illegal char!) and added '/' instead. But have a look at my finalãcorrection suggestion:ã}ããfunction ValidFileName(var FileName : PathStr) : Boolean;ãconstã IllegalCharsFN = '\';ã IllegalChars = ';,=+<>|"[]/';ãvarã Dir : DirStr;ã Name : NameStr;ã Ext : ExtStr;ãã { Contains returns true if S1 contains any characters in S2 }ã function Contains(S1, S2 : String) : Boolean; near; assembler;ã asmã {...see above...}ã end;ããbeginã ValidFileName := True;ã FSplit(FileName, Dir, Name, Ext);ã if not ((Dir = '') or PathValid(Dir)) orã Contains(Name, IllegalChars + IllegalCharsFN) orã Contains(Dir, IllegalChars) thenã ValidFileName := False;ãend;ã 66 01-27-9411:57ALL BILL HIMMELSTOSS dBase Manipulation IMPORT 65 o {ã{ If this code is used commercially, please send a few bucks to }ã{ Bill Himmelstoss, PO BOX 23246, Jacksonville, FL 32241-3246, }ã{ Otherwise, it's freely distributable. }ããunit DBF;ããinterfaceããusesã Objects,ã OString;ããtypeã TYMDDate = recordã Year,ã Month,ã Day: Byte;ã end;ãã PDatabase = ^TDatabase;ã TDatabase = object(TObject)ã DatabaseType: Byte;ã LastUpdate: TYMDDate;ã NumRecords: Longint;ã FirstRecordPos: Word;ã RecordLength: Word;ãã S: TDosStream;ã Pathname: TOString;ã Modified: Boolean;ã Fields: TCollection;ãã constructor Init(APathname: TOString);ã constructor InitCreate(APathname: TOString; AFields: PCollection);ã destructor Done; virtual;ã procedure RefreshHeader;ã procedure UpdateHeader;ã function GetRecord(RecordNum: Longint): Pointer;ã procedure PutRecord(RecordNum: Longint; Rec: Pointer);ã procedure Append(Rec: Pointer);ã procedure Zap;ã procedure RefreshFields;ã end;ãã PFieldDef = ^TFieldDef;ã TFieldDef = object(TObject)ã Name: TOString;ã DataType: Char;ã Displacement: Longint;ã Length: Byte;ã Decimal: Byte;ãã constructor Init(ã AName: String;ã ADataType: Char;ã ALength,ã ADecimal: Byte);ã destructor Done; virtual;ã constructor Load(var S: TStream);ã procedure Store(var S: TStream);ã end;ããimplementationããusesã WinDos;ããconstructor TDatabase.Init(APathname: TOString); beginã inherited Init;ã Pathname.InitText(APathname);ã S.Init(Pathname.CString, stOpen);ã if S.Status <> stOk then Fail;ã Fields.Init(5, 5);ã RefreshHeader;ãend;ããconstructor TDatabase.InitCreate(APathname: TOString; AFields: PCollection);ãconstã Terminator: Byte = $0D;ãvarã Year, Month, Day, Dummy: Word;ãã procedure CopyField(Item: PFieldDef); far;ã beginã Fields.Insert(Item);ã end;ãã procedure WriteFieldSubrecord(Item: PFieldDef); far;ã beginã Item^.Store(S);ã Inc(RecordLength, Item^.Length);ã end;ããbeginã inherited Init;ãã DatabaseType := $03;ã GetDate(Year, Month, Day, Dummy);ã LastUpdate.Year := Year - 1900;ã LastUpdate.Month := Month;ã LastUpdate.Day := Day;ã NumRecords := 0;ã RecordLength := 0;ãã Pathname.InitText(APathname);ã S.Init(Pathname.CString, stCreate);ã if S.Status <> stOk then Fail;ã UpdateHeader;ãã S.Seek(32); { beginning of field subrecords }ã Fields.Init(AFields^.Count, 5);ã AFields^.ForEach(@CopyField);ã Fields.ForEach(@WriteFieldSubrecord);ãã S.Write(Terminator, SizeOf(Terminator));ã Modified := true;ã FirstRecordPos := S.GetPos;ã UpdateHeader;ãend;ããdestructor TDatabase.Done;ãbeginã if Modified then UpdateHeader;ã Pathname.Done;ã S.Done;ã Fields.Done;ã inherited Done;ãend;ããprocedure TDatabase.RefreshHeader;ãvarã OldPos: Longint;ãbeginã OldPos := S.GetPos;ã S.Seek(0);ã S.Read(DatabaseType, SizeOf(DatabaseType));ã S.Read(LastUpdate, SizeOf(LastUpdate));ã S.Read(NumRecords, SizeOf(NumRecords));ã S.Read(FirstRecordPos, SizeOf(FirstRecordPos));ã S.Read(RecordLength, SizeOf(RecordLength));ã S.Seek(OldPos);ã RefreshFields;ãend;ããprocedure TDatabase.UpdateHeader;ãvarã OldPos: Longint;ã Reserved: array[12..31] of Char;ãbeginã OldPos := S.GetPos;ã S.Seek(0);ã S.Write(DatabaseType, SizeOf(DatabaseType));ã S.Write(LastUpdate, SizeOf(LastUpdate));ã S.Write(NumRecords, SizeOf(NumRecords));ã S.Write(FirstRecordPos, SizeOf(FirstRecordPos));ã S.Write(RecordLength, SizeOf(RecordLength));ã FillChar(Reserved, SizeOf(Reserved), #0);ã S.Write(Reserved, SizeOf(Reserved));ã S.Seek(OldPos);ãend;ããfunction TDatabase.GetRecord(RecordNum: Longint): Pointer; varã Temp: Pointer;ã Pos: Longint;ãbeginã Temp := NIL;ã GetMem(Temp, RecordLength);ã if Temp <> NIL thenã beginã Pos := FirstRecordPos + ((RecordNum - 1) * RecordLength);ã if S.GetPos <> Pos thenã S.Seek(Pos);ã S.Read(Temp^, RecordLength);ã end;ã GetRecord := Temp;ãend;ããprocedure TDatabase.Append(Rec: Pointer); beginã if Assigned(Rec) thenã beginã Modified := true;ã Inc(NumRecords);ã PutRecord(NumRecords, Rec);ã end;ãend;ããprocedure TDatabase.PutRecord(RecordNum: Longint; Rec: Pointer); varã Pos: Longint;ãbeginã if Assigned(Rec) and (RecordNum <= NumRecords) thenã beginã Pos := FirstRecordPos + ((RecordNum - 1) * RecordLength);ã if S.GetPos <> Pos thenã S.Seek(Pos);ã S.Write(Rec^, RecordLength);ã end;ãend;ããprocedure TDatabase.Zap;ãvarã T: TDosStream;ã Temp, D, N, E: TOString;ã F: File;ãbeginã D.Init(fsDirectory);ã N.Init(fsFilename);ã E.Init(fsExtension);ã FileSplit(Pathname.CString, D.CString, N.CString, E.CString);ã D.RecalcLength;ã N.RecalcLength;ã E.RecalcLength;ã Temp.InitText(D);ã Temp.Append(N);ã Temp.AppendP('.TMP');ã D.Done;ã N.Done;ã E.Done;ãã T.Init(Temp.CString, stCreate);ã S.Seek(0);ã T.CopyFrom(S, FirstRecordPos - 1);ã T.Done;ã S.Done;ã Assign(F, Pathname.CString);ã Erase(F);ã Assign(F, Temp.CString);ã Rename(F, Pathname.CString);ã S.Init(Pathname.CString, stOpen);ã NumRecords := 0;ã Modified := false;ã UpdateHeader;ãend;ããprocedure TDatabase.RefreshFields;ãvarã Terminator: Byte;ã HoldPos: Longint;ã FieldDef: PFieldDef;ãbeginã S.Seek(32); { beginning of Field subrecords }ãã repeatã HoldPos := S.GetPos;ã S.Read(Terminator, SizeOf(Terminator));ã if Terminator <> $0D thenã beginã S.Seek(HoldPos);ã FieldDef := New(PFieldDef, Load(S));ã Fields.Insert(FieldDef);ã end;ã until Terminator = $0D;ãend;ããconstructor TFieldDef.Init(ã AName: String;ã ADataType: Char;ã ALength,ã ADecimal: Byte);ãbeginã inherited Init;ã Name.InitTextP(AName);ã DataType := ADataType;ã Length := ALength;ã Decimal := ADecimal;ã Displacement := 0;ãend;ããdestructor TFieldDef.Done;ãbeginã Name.Done;ã inherited Done;ãend;ããconstructor TFieldDef.Load(var S: TStream); varã AName: array[1..11] of Char;ã Reserved: array[18..31] of Char;ãbeginã S.Read(AName, SizeOf(AName));ã Name.Init(SizeOf(AName));ã Name.SetText_(@AName[1], 11);ã S.Read(DataType, SizeOf(DataType));ã S.Read(Displacement, Sizeof(Displacement));ã S.Read(Length, SizeOf(Length));ã S.Read(Decimal, SizeOf(Decimal));ã S.Read(Reserved, SizeOf(Reserved));ãend;ããprocedure TFieldDef.Store(var S: TStream); varã Reserved: array[18..31] of Char;ãbeginã S.Write(Name.CString^, 11);ã S.Write(DataType, SizeOf(DataType));ã S.Write(Displacement, Sizeof(Displacement));ã S.Write(Length, SizeOf(Length));ã S.Write(Decimal, SizeOf(Decimal));ã FillChar(Reserved, SizeOf(Reserved), #0);ã S.Write(Reserved, SizeOf(Reserved));ãend;ããend.ããããããprogram DbfTest;ããusesã dbf, wincrt, ostring, objects, strings;ããtypeã PDbfTest = ^TDbfTest;ã TDbfTest = recordã Deleted: Char; { ' '=no, '*'=yes }ã AcctNo: array[1..16] of Char;ã Chunk: array[1..8] of Char;ã Baskard: array[1..5] of Char;ã Extra: array[1..8] of Char;ã Sandwich: array[1..25] of Char;ã end;ããvarã rec: PDbfTest;ã database: tdatabase;ã pathname: tostring;ã temp: string;ã fields: tcollection;ãã procedure DoShow;ãã procedure show(item: pfielddef); far;ã beginã writeln(ã item^.name.cstring:15, ' ',ã item^.datatype, ' ',ã item^.length:10, ' ',ã item^.decimal:10, ' ');ã end;ãã beginã database.fields.foreach(@show);ã end;ãããbeginã InitWinCrt;ãã fields.init(5, 0);ã fields.insert(new(pfielddef, init('ACCTNO', 'C', 16, 0)));ã fields.insert(new(pfielddef, init('CHUNK', 'N', 8, 2)));ã fields.insert(new(pfielddef, init('BASKARD', 'C', 5, 0)));ã fields.insert(new(pfielddef, init('EXTRA', 'D', 8, 0)));ã fields.insert(new(pfielddef, init('SANDWICH', 'C', 25, 0)));ã pathname.inittextp('c:\dbftest.dbf');ã database.initcreate(pathname, @fields);ã pathname.done;ã DoShow;ãã New(Rec);ã with Rec^ doã beginã Acctno := '1313558000001005'; { <-will self-check, but not valid }ã Chunk := ' 10.00';ã Baskard := 'ABCDE';ã Extra := '19931125';ã Sandwich := 'Turkey Leftovers ';ã end;ã database.append(rec);ã dispose(rec);ãã rec := database.getrecord(1);ã writeln(rec^.acctno, ' ', rec^.Sandwich);ã dispose(rec);ãã database.done;ãend.ã 67 01-27-9411:59ALL HERB BROWN Hexagonal Grid Info IMPORT 50 o)î {ãI have a game I would like to make a PD project. It's a war game, based onãolder style equipment, i.e., no nukes and such. I haven't worked on it inãseveral years, though. I would like to make it multi node, or multi playerãsomehow. I think it would make a perfect object of discussion. It's writtenãin Pascal and was originally started in 4.0. It needs to be re-written intoãobjects and the code updated througout. (My programming habits have changedãsignifically, I may make less errors now, but, when I do, they are reallyãstupid.)ããCoordinating movements will be a challenge in a multi node system.ããthe logic would need to be changed, i.e., the movement directions, toãaccomodate ASCII characters that would represent the playing peices..ããHere is code for a grid system I wrote...ã}ããProgram FillGrid;ãã{ example of filling a hex sided grid with data about itself and it'sã neighbors.ãã Written By: Herbert Brown and released to the public domain (1993)ã please give credit were credit is due.. }ããusesã dos,ã crt; { only for debugging }ããconstã MaxRows = 7;ã MaxColumns = 5;ã MaxHex = 32; { only used for array and testing }ããtypeã grid = recordã id, nw, ne,ã w, e, se, sw,ã TerrainRec : Longint; { can be used as a reference to a database}ã end;ããvarã GridVar : Array [1..MaxHex] of grid;ã gridCounter : Longint;ã RowCounter,ã ColCounter,ã EndColumn : Longint;ã OddRow,ã finished : Boolean;ã CurrentGrid : grid;ã x : integer;ãããprocedure getit(ColCounter, RowCounter, GridCounter, MaxColumns,ã MaxRows : Longint; Var CurrentGrid : grid);ããbeginã CurrentGrid.id := gridcounter;ãã { The 9 possible cases tested Middle tested first for speed because thereã are more of these in large maps }ãã {middle}ã if ((colcounter > 1) and (colcounter < EndColumn)) thenã if (rowcounter <> 1) and (rowcounter <> maxrows) thenã beginã CurrentGrid.nw := (gridcounter-MaxColumns);ã CurrentGrid.w := (gridcounter-1);ã CurrentGrid.sw := (gridcounter+MaxColumns)-1;ã CurrentGrid.se := gridcounter+maxColumns;ã CurrentGrid.e := gridcounter+1;ã CurrentGrid.ne := (gridcounter-MaxColumns)+1;ã exit;ã end;ãã {leftedge}ã if (colcounter = 1) and (rowcounter <> 1) thenã if (rowcounter <> maxrows) thenã beginã if oddrow thenã CurrentGrid.nw := (gridcounter-MaxColumns)ã elseã CurrentGrid.nw := 0; { }ã CurrentGrid.w := 0;ã if oddrow thenã CurrentGrid.sw := (gridcounter+MaxColumns)-1ã elseã CurrentGrid.sw := 0;ã CurrentGrid.se := gridcounter+maxColumns;ã CurrentGrid.e := gridcounter+1;ã CurrentGrid.ne := (gridcounter-MaxColumns)+1;ã exit;ã end;ãã {rightedge}ã if (colcounter = EndColumn) and (rowcounter <> 1) thenã if (rowcounter <> maxrows) thenã beginã CurrentGrid.nw := (gridcounter-MaxColumns);ã CurrentGrid.w := (gridcounter-1);ã CurrentGrid.sw := (gridcounter+MaxColumns)-1;ã if oddrow thenã CurrentGrid.se := gridcounter+maxColumnsã elseã CurrentGrid.se := 0;ã CurrentGrid.e := 0;ã if oddrow thenã CurrentGrid.ne := (gridcounter-MaxColumns)+1ã elseã CurrentGrid.ne := 0;ã exit;ã end;ãã {toprow}ã if (rowcounter = 1) and (colcounter <> 1) thenã if (colcounter <> maxcolumns) thenã beginã CurrentGrid.nw := 0;ã CurrentGrid.w := (gridcounter-1);ã CurrentGrid.sw := (gridcounter+MaxColumns)-1;ã CurrentGrid.se := gridcounter+maxColumns;ã CurrentGrid.e := gridcounter+1;ã CurrentGrid.ne := 0;ã exit;ã end;ãã {BottomRow}ã if (rowcounter = maxrows) and (colcounter <> 1) thenã if (colcounter <> maxcolumns) thenã beginã CurrentGrid.nw := (gridcounter-MaxColumns);ã CurrentGrid.w := (gridcounter-1);ã CurrentGrid.sw := 0;ã CurrentGrid.se := 0;ã CurrentGrid.e := gridcounter+1;ã CurrentGrid.ne := (gridcounter-MaxColumns)+1;ã exit;ã end;ããã {TopLeftCorner}ã if (colcounter = 1) and (rowcounter = 1) thenã beginã CurrentGrid.nw := 0; { Can't leave edge! }ã CurrentGrid.w := 0;ã CurrentGrid.sw := 0;ã CurrentGrid.se := gridcounter+maxColumns;ã CurrentGrid.e := gridcounter+1;ã CurrentGrid.ne := 0;ã exit;ã end;ãã {toprightcorner}ã if (rowcounter = 1) and (colcounter = maxcolumns) thenã beginã CurrentGrid.nw := 0;ã CurrentGrid.w := (gridcounter-1);ã CurrentGrid.sw := (gridcounter+MaxColumns)-1;ã CurrentGrid.se := 0;ã CurrentGrid.e := 0;ã CurrentGrid.ne := 0;ã exit;ã end;ãã {bottomleftCorner}ã if (colcounter = 1) and (rowcounter = maxrows) thenã beginã CurrentGrid.nw := 0;ã CurrentGrid.w := 0;ã CurrentGrid.sw := 0;ã CurrentGrid.se := 0;ã CurrentGrid.e := gridcounter+1;ã CurrentGrid.ne := (gridcounter-MaxColumns)+1;ã exit;ã end;ãã {BottomRightCorner}ã if (colcounter = maxcolumns) and (rowcounter = maxrows) thenã beginã CurrentGrid.nw := (gridcounter-MaxColumns);ã CurrentGrid.w := (gridcounter-1);ã CurrentGrid.sw := 0;ã CurrentGrid.se := 0;ã CurrentGrid.e := 0;ã CurrentGrid.ne := 0;ã exit;ã end;ããend;ããbeginã clrscr;ã { fill the record array out for debugging or "watch" purposesã this loop was only used for debugging }ã for x := 1 to MaxHex doã beginã GridVar[x].id := 0;ã gridvar[x].nw := 0;ã gridvar[x].ne := 0;ã gridvar[x].w := 0;ã gridvar[x].e := 0;ã gridvar[x].se := 0;ã gridvar[x].sw := 0;ã gridVar[x].TerrainRec:=0;ã end;ãã fillchar(CurrentGrid,sizeof(currentgrid),0);ã GridCounter := 1;ã RowCounter:=1;ã ColCounter:=1;ã Oddrow:=False;ã Finished := False;ã EndColumn := MaxColumns;ãã while not finished doã begin { while }ã getit(ColCounter,RowCounter,GridCounter,MaxColumns,MaxRows,CurrentGrid);ã gridvar[gridcounter]:=CurrentGrid; { <- can be stored to a vitual array orã data base file here }ã Inc(ColCounter); { next grid id }ã Inc(gridCounter);ã if colcounter = EndColumn+1 thenã beginã Oddrow := not oddrow;ã ColCounter:=1;ã if rowcounter = MaxRows thenã finished := True;ã inc(rowcounter); { next row }ã if not oddrow thenã EndColumn := MaxColumnsã elseã EndColumn := MaxColumns - 1;ã end;ã end;ãend.ã 68 01-27-9412:02ALL GREG VIGNEAULT EXE to binary Converter IMPORT 48 ooê {ã> Run this program, it will create ULONGS.ZIP, which contains theã> ULONGS.OBJ file needed for the LongXXX functions...ã> That's too cool! How'd you do that? You got a program to doã> that with?ãã Yes, it's a little utility that I wrote, named GBUG...ãã It can transform a binary file into one of three ASCII files:ã 1) a script that is fed to DEBUG.COM (this is the default mode)ã 2) a Turbo Pascal source code file (using the /P option)ã 3) a GW-BASIC source code file (using the /B option)ãã The output file (.SCR, .PAS, or .BAS) can then be posted onto text-ã based mediums, such as BBS conferences. Receivers can recover theã binary file without any special decoding utilities.ãã Since GBUG doesn't embed any error-detection code, it's best toã _always_ compress the original binary -- so that transportationã errors can be detected during the file decompression stage.ãã Here's GBUG15B.LZH, which contains GBUG version 1.5b ...ãã(**********************************************************************)ã}ãPROGRAM A; VAR G:File; CONST V:ARRAY [ 1..1326 ] OF BYTE =(ã33,109,45,108,104,53,45,10,5,0,0,226,5,0,0,100,18,82,26,32,1,8,71,66,ã85,71,46,67,79,77,20,118,77,0,0,4,211,107,163,22,54,148,47,236,176,138,ã139,32,197,189,172,76,77,133,38,141,28,57,194,120,25,2,68,75,109,198,ã186,228,53,214,109,193,10,2,28,77,52,95,2,195,192,50,15,129,44,51,180,ã218,203,178,10,169,45,234,6,28,90,117,182,234,84,128,83,173,215,96,217,ã187,247,36,49,174,237,157,117,70,98,230,147,253,251,111,42,69,192,48,ã155,127,169,135,192,222,194,198,211,108,80,245,3,16,102,204,61,183,213,ã54,96,166,204,193,155,51,172,78,1,134,123,200,39,157,207,9,217,33,140,ã113,225,131,38,253,173,179,124,144,190,120,238,36,80,198,146,113,231,ã157,8,61,32,202,143,28,93,48,188,191,11,216,81,96,7,43,8,128,61,124,144,ã189,129,6,245,216,78,114,229,173,229,190,20,28,76,113,99,145,33,237,249,ã142,26,154,220,157,226,53,228,183,121,119,133,27,175,215,201,155,48,47,ã109,174,27,113,240,116,213,70,196,148,70,167,214,215,14,73,212,156,96,ã59,126,31,174,13,211,171,201,81,251,151,95,108,113,60,135,1,216,113,133,ã140,27,247,135,133,230,4,88,120,17,66,116,64,254,114,131,37,52,48,67,ã148,25,65,138,240,34,146,124,3,159,134,55,100,80,207,189,119,20,140,24,ã143,185,167,246,112,163,29,125,133,141,218,230,227,97,198,236,144,244,ã50,93,192,232,197,36,184,250,249,228,72,4,100,147,18,20,72,176,57,225,ã199,76,200,41,153,133,245,199,43,144,225,173,231,24,208,202,200,200,205,ã196,39,137,97,130,225,189,224,99,18,92,111,114,234,216,217,179,38,119,ã112,28,220,222,55,146,24,47,112,32,135,165,139,202,251,49,110,186,97,ã66,236,148,202,222,231,233,111,151,252,38,196,74,52,39,231,69,56,34,78,ã84,199,16,120,215,46,66,43,102,182,237,220,145,64,145,136,248,247,189,ã209,61,58,36,49,10,25,209,5,255,252,141,241,60,64,126,25,130,238,249,ã59,147,255,39,216,183,216,54,2,232,50,84,171,87,89,79,177,189,189,234,ã212,245,129,168,85,24,202,115,50,247,163,165,175,224,19,207,82,21,73,ã108,210,176,155,49,110,232,53,213,131,150,174,185,104,250,22,185,107,ã198,253,214,121,57,110,155,172,170,75,110,63,10,104,94,186,206,99,188,ã26,125,166,38,242,195,118,57,201,111,6,199,118,63,108,158,132,35,52,54,ã227,151,235,75,217,211,210,158,118,122,183,84,201,145,218,229,208,71,ã49,215,242,194,114,57,58,254,95,136,205,142,30,188,73,45,25,154,218,218,ã8,210,172,51,92,46,242,209,244,80,153,253,181,197,89,169,167,173,90,57,ã41,46,27,153,181,181,131,164,35,42,196,201,42,101,171,81,76,204,98,81,ã60,205,6,67,76,72,197,107,9,11,146,51,51,106,9,10,180,35,218,104,22,56,ã157,99,240,99,84,72,234,117,127,24,93,47,3,132,106,107,183,35,232,168,ã195,177,187,27,41,226,102,136,154,116,42,36,88,233,13,150,103,151,165,ã128,179,42,36,33,57,198,117,157,168,151,76,86,233,14,22,181,137,99,33,ã49,119,99,6,225,81,122,67,5,106,166,67,21,158,252,107,242,168,9,194,70,ã85,180,203,168,145,169,213,176,102,60,245,102,165,104,173,165,237,68,ã134,27,145,212,72,81,176,92,132,211,75,64,60,186,116,49,93,120,215,33,ã114,225,36,57,60,193,226,6,185,120,215,87,80,69,71,186,103,188,185,8,ã238,167,18,53,64,60,205,99,188,213,127,12,254,117,19,11,1,101,3,41,83,ã29,248,218,59,7,113,85,159,12,75,216,217,12,202,181,228,167,190,254,126,ã200,218,251,10,217,236,217,165,58,175,133,235,250,118,155,51,61,15,82,ã117,94,238,126,209,69,167,179,180,243,128,146,163,52,44,135,19,104,161,ã244,38,156,208,122,84,140,89,140,130,6,104,111,199,47,102,211,244,6,170,ã146,137,5,159,16,69,240,198,102,213,114,196,35,155,156,73,162,153,228,ã248,235,56,61,165,227,179,249,6,156,241,59,204,158,170,78,192,218,31,ã29,85,5,30,106,242,92,166,83,133,75,95,193,215,172,225,107,163,236,50,ã255,81,118,184,48,17,180,169,65,23,89,205,16,7,22,145,139,33,214,175,ã26,15,205,237,161,12,223,192,30,209,69,237,209,2,210,139,226,8,31,1,69,ã239,145,7,204,83,11,33,131,88,81,117,104,131,231,40,28,234,64,48,42,169,ã32,146,172,121,232,131,226,41,65,218,120,215,97,110,21,169,221,228,222,ã120,229,40,236,82,119,151,15,77,85,20,218,72,130,42,97,84,113,176,21,ã229,22,249,16,62,41,82,83,145,151,76,65,235,21,232,178,68,68,181,233,ã220,204,143,218,200,102,194,84,150,216,105,229,36,55,90,36,8,38,33,44,ã242,134,85,19,18,196,163,190,13,34,191,236,201,126,111,132,187,113,131,ã213,83,106,69,116,42,146,172,30,34,120,144,204,107,188,10,137,153,121,ã190,136,37,20,231,232,76,97,214,171,53,89,49,55,182,70,115,102,167,143,ã207,22,0,210,147,44,78,132,61,55,26,197,154,92,13,29,234,116,79,48,184,ã104,131,136,165,57,75,229,82,93,218,32,226,169,177,33,196,178,35,242,ã80,35,70,15,190,138,238,69,21,29,242,210,68,22,234,116,230,95,8,44,212,ã151,222,68,29,53,54,51,196,142,142,216,96,154,85,131,52,152,146,134,19,ã36,224,169,96,200,105,228,79,238,75,158,12,133,37,242,70,9,106,104,209,ã212,227,208,176,35,127,220,164,187,81,131,252,82,15,97,79,152,244,175,ã27,105,237,183,0,217,97,54,241,119,239,226,70,80,162,85,198,248,26,63,ã147,111,233,253,215,110,3,96,182,209,127,238,118,30,204,255,112,192,0ã); BEGIN Assign(G,'GBUG15B.LZH'); Rewrite(G,SizeOf(V));ã BlockWrite(G,V,1); Close(G); END {Gbug1.5b}.ã 69 01-27-9412:15ALL MARTIN RICHARDSON Do Nothing! IMPORT 16 oÒ? {ã>Well, Uh, I meant creating pascal compiled files, and basic compiledã>files and putting them in a BAT file so that they will execute in order.ãã>Oh and, uh , how to do you compile programs in tp 7 so that they are notã> broken (or shut off in the middle if someone pressed control break)?ã>I can't stop the control break thing...ããA common question. Here is my solution:ãã{****************************************************************************ã * Procedure ..... DoNothingã * Purpose ....... A do-nothing procedure to intercept interrupts and stopã * them from happening.ã * Parameters .... Noneã * Returns ....... Nothingã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... February 19, 1993ã ****************************************************************************}ãã{$F+}ãPROCEDURE DoNothing; INTERRUPT;ãBEGINãEND;ã{$F-}ãã{****************************************************************************ã * Procedure ..... SetBreak()ã * Purpose ....... To dis-allow CTRL-BREAKING out of a program.ã * Parameters .... SetOn False to turn CTRL-BREAK offã * True to turn it back on againã * Returns ....... Nothingã * Notes ......... Uses the procedure DoNothing above to remap INT 1Bh to.ã * Author ........ Martin Richardsonã * Date .......... February 19, 1993ã ****************************************************************************}ãPROCEDURE SetBreak( SetOn: BOOLEAN );ãCONST Int1BSave : Pointer = NIL;ãBEGINã IF NOT SetOn THEN BEGINã GetIntVec($1B,Int1BSave);ã SetIntVec($1B,Addr(DoNothing));ã END ELSEã IF Int1BSave <> NIL THEN SetIntVec($1B,Int1BSave);ãEND;ãã{ãHowever, this method will not prevent them from breaking out of the .BATãfile you described above to link the programs together with! (You willãneed a TSR to do that.)ã}ãã 70 01-27-9412:16ALL PHIL NICKELL Do Nothing Again! IMPORT 12 o« (*ã³{$F+}ã³PROCEDURE DoNothing; INTERRUPT;ã³BEGINã³END;ã³{$F-}ãã Would you believe that the code in your DoNothing procedure can beã improved for smaller size and better speed? (No, I'm not kidding,ã please read on.) The standard preamble and postamble code generated byã Turbo Pascal for a procedure of type Interrupt pushes a whole wad ofã registers, sets the BP and DS registers, and then undoes it all beforeã the IRET. Your DoNothing procedure compiles to code that looksã something like this:ãã { preamble }ã PUSH AX BX CX DX SI DI DS ES BPã MOV BP, SPã MOV AX, @DATAã MOV DS, AXã { postamble }ã POP BP ES DS DI SI DX CX BX AXã IRETãã The following procedure provides identical results and kills theã overhead.ã*)ã {$f+}ã PROCEDURE DoNothing; ASSEMBLER; { Coded as Int Handler }ã asmã IRET { return from interrupt }ã end;ã {$f-}ã(*ã With no parameters and no local vars Turbo Pascal generates no preambleã code, and generates only a long return as postamble. The resultingã compiled code from my DoNothing proc looks like this:ãã IRETã RETãã The difference: 26 bytes and many stack memory accesses for the nullã Interrupt procedure versus only 2 bytes in the null Assembler procedureã with Iret. The RET never gets executed, of course.ã*)ã 71 01-27-9412:16ALL ALTON PRILLAMAN OP Pick Lists IMPORT 51 o. {ã>I've been trying to create a simple pick list using Object Proffesional andã>can't seem to get it to do what I want. I'm using the expick.pas example asã>start for creating my pick list. Everything is pretty much the same exceptã>that I want my pick list to exit with other keys insted of the enter key.ã>The manual doesn't go into detail about this.ããCheck out the docs for OpCmd. The procedure that you're wanting isã"AddCommand". In my example below, I've set up a multiple choice listãthat "remaps" the key to toggle (like the ) and useã to accept the choices. Here's my example:ãã{DON'T FORGET TO "USE" OpCmd}ããusesã OpCmd; {among others}ããprocedure GetPicks;ãvarã PL :PickList;ã PickDone :boolean;ããbeginã if not PL.InitDeluxe(screenwidth shr 1-16,5,ã screenwidth shr 1+15,screenheight-6,ã AltMenuCS, {color set}ã WinOpts, {window options}ã 33, {width of pick list strings}ã NumItems, {number of items}ã UserStrings, {user-string proc}ã PickVertical, {pick direction-type}ã MultipleChoice,{single or multiple}ã pkStick)then {stick at edges}ã beginã {error message}ã exit;ã end;ã PickCommands.AddCommand(ccToggle,1,$1C0D,0); {Enter=Toggle}ã PickCommands.AddCommand(ccSelect,1,$4400,0); {F10=Accept}ã PickDone:=false;ã repeatã PL.Process;ã case PL.GetLastCommand ofã ccSelect: {F10}ã beginã end;ãã ccQuit:ã PickDone:=true;ãã ccError:ã beginã PickDone:=true;ã end;ã end; {case}ã until PickDone;ã HideMouse;ãã {NOTE THE FOLLOWING LINES: They're needed to remap the ã key to its original setting and gets rid of the key asã the ccSelect. If you want *ALL* of your pick lists throughoutã your program to behave this way, use the PickCommands.AddCommandã at the beginning of your program.}ãã PickCommands.AddCommand(ccSelect,1,$1C0D,0); {Enter=Toggle}ã PickCommands.AddCommand(ccNone,1,$4400,0); {F10=Accept}ã PL.Done;ã end;ãend;ãã{ãCHARLES SERFOSSãã>I've been trying to create a simple pick list using Object Proffesional andã>can't seem to get it to do what I want. I'm using the expick.pas example as aã>start for creating my pick list. Everything is pretty much the same exceptã>that I want my pick list to exit with other keys insted of the enter key.ã>The manual doesn't go into detail about this.ããYou'll have to use the "AddCommand" method. Here's an example. This isãbased on "expick1.pas" from Page 4-186 of Book #1.ã}ããprogram PickListExample;ãusesã OpCrt, OpRoot, OpCCmd, OpFrame, OpWindow, OpPick;ãconstã NumPizzaToppings = 5;ãvarã PizzaTop : PickList;ã PickWindowOptions : Longint;ããprocedure PizzaTopping(Item : Word { etc... }) : Far;ãbeginãend;ããbegin { Main }ã if not PizzaTop.InitCustom(35, 5, 45, { etc ... }) then beginã halt;ã end;ã PizzaTop.SetSearchMode(PicckCharSearch);ã PizzaTop.EnableExplosion(20);ã with PizzaTop.wFrame do beginã AddShadow...ã AddHeader...ã end;ã { *************** Decide Which Keys In Addition To Defaults To Allow }ã { PickCommands is just mentioned at the end of page 4-207. The }ã { CommandProcessor Type allows you to use the functions in section }ã { (E) OPCMD - Page 3-82. See Page 3-95 for documentation on }ã { the "AddCommand" method! }ã { *******************************************************************}ã with PickCommands doã beginã AddCommand(ccUser1,1,$5200,0); { $5200 = scan code for INS }ã AddCommand(ccUser2,1,$5300,0); { $5300 = scan code for DEL }ã end;ã PizzaTop.Process;ã PizzaTop.Erase;ã case PizzaTop.GetLastCommand ofã ccUser1 : ; { If User hits INS, this is executed }ã ccUser2 : ; { If User hits DEL, this is executed }ã ccSelect : writeln('You chose : ',PizzaTop.GetLastChoiceString);ã end;ã PizzaTop.Done;ãend. { Main }ãã{ãDAVID HOWORTHãã> I've been trying to create a simple pick list using Object Proffesionalã> can't seem to get it to do what I want. I'm using the expick.pas examplã> start for creating my pick list. Everything is pretty much the same excã> that I want my pick list to exit with other keys insted of the enter keã> The manual doesn't go into detail about this.ããNick--The manual does go into subtantial detail. You just need toãknow where to look. As with much of OPro, the things you want toãdo with a particular object may be implemented, not in the objectãper se, but in one of its ancestors. It always pays to look in theãmanual at the ancestor's methods.ããYou need to read up on CommandWindow, from which PickList isãdescended, and on CommandProcessor, in OpCmd. Here's a relevantãpiece of code from one of my programs. The first AddCommand addsãan additional Quit; the others are for purposes specific to myãapplication, not for predefined commands such as ccQuit.ã}ãwith DialPickList { a PickList descendent } doãã with PickCommands do beginã { Simulate WordPerfect's exit command }ã AddCommand(ccQuit,1,$4100,0); { F7 }ãã { ccUser0 = Add a new phone entry }ã AddCommand(ccUser0,1,$1E00,0); {Alt-A}ã AddCommand(ccUser0,1,$5200,0); {Ins}ãã { ccUser1 = Delete a phone entry }ã AddCommand(ccUser1,1,$2000,0); {Alt-D}ã AddCommand(ccUser1,1,$5300,0); {Del}ãã { ccUser2 = Edit a phone entry }ã AddCommand(ccUser2,1,$1200,0); {Alt-E}ãã { ccUser3 = Reconfigure Comm Stuff }ã AddCommand(ccUser3,1,$2E00,0); {Alt-C}ãã { ccUser4 = View log (the printing and purging routines branchã from the browsing routine }ã AddCommand(ccUser4,1,$2F00,0); {Alt-V}ãã end; { with PickCommands }ããend; { with DialPickList }ã 72 01-27-9412:17ALL DJ MURDOCH Program Origin IMPORT 3 o(= ã{$X+} { Need this for easy handling of Asciiz strings }ãvarã parentseg : ^word;ã p : pchar;ãbeginã parentseg := ptr(prefixseg,$16);ã p := ptr(parentseg^-1,8);ã writeln('I was launched by ',p);ãend.ãã 73 01-27-9412:19ALL PIGEON STEVEN Eight Queens IMPORT 39 oWÎ {ã[email protected] (Pigeon Steven)ãã> Hey, I have a friend who is taking a Pascal class at another col-ã>lege and he asked me to make a query of you all. Basically, he has toã>do the "eight queens" on a chessboard (with none of them interferingã>vertically, horizontally, or diagonally with each other) problem inã>Pascal. The program has to use stacks. Its input is the number ofã>queens (the dimensions of the chessboard are that number x that number).ã>The output is that it can't be done with that number of queens or aã>grid of the queens and either empty spaces or dashes. I was wonderingã>if any of you had any similar programs in old code lying around, and ifã>so if you could send it to me. My friend says it's a pretty classicã>problem for programmers, so I figured I'd ask. Oh, and in case some ofã>you think that I am this "friend", the only Pascal course here at Brownã>(cs15) has already done its job with stacks, and it wasn't this. Btw,ã>speaking of cs here, it's Object-Oriented; my friend's program needs toã>be done procedureally (straight-line), not in OOPas. I thank you allã>for your indulgence in allowing me to post this. Please don't flame me,ã>as I am only trying to help out a friend. If there is a more appropriateã>place for me to post this, please tell me (I am going to post this toã>cs groups if possible). Oh, and as I don't get around here often, Iã>would appreciate it much if any and all replies were sent to the addressã>below. Thanx,ã>ããHere's a programm that does that. It's a little bit strange, but I putãextra code so the board would not be passed as a parameter (since TurboãProfiler said :"Hey, 75% of your run time goes in copy of the board").ãThe file is name REINES5.PAS (litterally QUEENS5.PAS) and it's limitedã(so to say) to 64x64 boards (with 64 queens on it). It is fast enough.ããã}ã program Probleme_des_reines;ãã const max = 64;ã libre = 8;ã reine = 8;ãã const colname:string =ã 'abcdefghijklmnopqrstuvwxyz'+ã 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'+ã 'àáâçäåæèéêë';ã type echiquier = array[1..max,1..max] of byte;ã var sol,recursions:longint;ã top:word;ã Reines,Attaques:echiquier;ããã function min(a,b:integer):integer;ã beginã if a0 thenã for i:=1 to min(top-g+1,t) doã beginã inc(attaques[t,g]);ã dec(t);ã inc(g);ã end;ãã Reines[x,y]:=reine;ãã end;ãã procedure unmark(x,y:integer);ã var t,g,i:integer;ã beginã for t:=y+1 to top do dec(attaques[x,t]);ãã t:=x+1;ã g:=y+1;ãã for i:=1 to min(top-t,top-g)+1 doã beginã dec(attaques[t,g]);ã inc(t);ã inc(g);ã end;ããã t:=x-1;ã g:=y+1;ãã if t>0 thenã for i:=1 to min(top-g+1,t) doã beginã dec(attaques[t,g]);ã dec(t);ã inc(g);ã end;ãã Reines[x,y]:=libre;ãã end;ãããã procedure traduit;ã var t,g:integer;ã beginã write(sol:4,'. ');ã for t:=1 to top doã for g:=1 to top doã if Reines[g,t]=reine then write(colname[t],g,' ');ã writeln(' ',recursions);ã end;ããã function find(level,j:integer):integer;ã beginã inc(j);ã while (attaques[j,level]<>libre) and (j0ã then beginã if level=topã then beginã inc(sol);ã Reines[t,level]:=reine;ã traduit;ã Reines[t,level]:=libre;ã endã else beginã mark(t,level);ã recurse(level+1);ã unmark(t,level);ã end;ã endã until (t=0) or (t=top);ã end;ããã function fact(n:real):real;ã beginã if n<=1 then fact:=1ã else fact:=n*fact(n-1);ã end;ããã var a:echiquier;ã i:integer;ã beginããã sol:=0;ã val(paramstr(1),top,i);ã if top>maxã then beginã writeln('! ',Top,' a ete remis a ',max,' (max)');ã top:=max;ã end;ãã if top<1 then top:=1;ãã writeln;ã writeln(' Le probleme des ',top,' reines FAST (c) 1992-1993 Steven Pigeon');ã writeln;ãã recursions:=0;ã fillchar(attaques,sizeof(attaques),libre);ã fillchar(Reines,sizeof(Reines),libre);ã recurse(1);ã writeln;ã writeln(' Solutions: ',sol);ã writeln(' Recursions: ',recursions,' (au lieu de ',fact(top):0:0,')');ã end.ãã 74 01-27-9412:23ALL TONY NUGENT TOT Info IMPORT 24 oX {ãI've just "completed" (are programs *ever* completed?:) a ratherãlarge programming project for a 3rd year uni subject.ããWe chose to use TechnoJock's Object Toolkit (currently availableãversion via Internet ftp) for much of the user interface (I'mãsorry we didn't look at TurboVision, but that's another story),ãand I must admit that I was impressed with its overallãfunctionality (I counted 87 different objects along with manyãuseful non-object procedures), its ease of use and the generallyãflawless results it produced.ããHowever, there is a MAJOR point that I would like to share withãyou all about this great toolkit that is NOT documented butãESSENTIAL to know about if you use it.ããThe problem was that after a program that uses TOT was run, theãsystem became very unstable afterwards with memory problems,ãusually locking up or something similar when subsequent programsãare run.ããI solved this problem by calling all the destructor Done methodsãof all the active TOT objects, then disposing of those on theãmemory heap just before exiting the program. Now the TOT docsãactually discourages this, but they don't mention that it doesãindeed NEED to be done before termination of the program.ããFor example:ã}ããusesã Crt, { Borland }ã totINPUT,ã totFAST,ã totDir,ã totIO1,ã totMSG,ã totKEY,ã totWIN,ã totLIST,ã totLINK,ã totLOOK,ã totSYS,ã totDATE;ã { TechnoJocks }ã { other units }ãã{ Then later... }ããprocedure TidyUpMess;ã{ shutdown procedure }ãbeginã { Tidy up after ourselves }ã dispose(myobjects, Done);ã { Tidy up after TechnoJocks }ã Mouse.Hide; { turn off the mouse }ã Screen.CursOn; { vain attempt to get a cursor back in DOS }ã Screen.Done; { totFAST - the screen object is a variable}ã Key.Done; { totINPUT }ã Mouse.Done { totINPUT }ã Dispose(ALPHABETtot,Done); { totINPUT }ã Dispose(LOOKtot,Done); { totLOOK }ã Dispose(MONITOR,Done); { totSYS }ã Dispose(IOtot,Done); { totIO }ã Dispose(DATEtot,Done); { totDATE }ã Dispose(SCROLLtot,Done); { totFAST }ã Dispose(SHADOWtot,Done); { totFAST }ãend;ãã{ãThis does the job nicely... no more problems (that I could find,ãanyway). Note that the order of some of these calls is important.ããThe only problem that remains is that on dropping back to dos theãcursor is no longer there (but only with command.com - NOT ifã4dos is installed - _strange_ indeed).ããBTW, does anybody have a nice fix for this missing cursor?ããHopefully somebody will find this hard-found information useful.ãIf someone knows how to email or netmail the authors, then I'mãsure that they would like to know about this too; all I've gotãabout them is the following:ãã TechnoJock Software, Inc.ã PO Box 820927ã Houston TX 77282ã Enquiries (713) 493-6354ã Compuserve ID: 74017,227ã Fax: (713) 493-5872ã}ã 75 01-27-9412:24ALL PETER BEEFTINK UUDecode! IMPORT 47 oS {ã> Yeah ! Please post your UU(EN/DE)CODE here ! I am interested, as well !ããand the decode as well.ã}ããprogram uudecode;ãã CONST defaultSuffix = '.uue';ã offset = 32;ãã TYPE string80 = string[80];ãã VAR infile: text;ã fi : file of byte;ã outfile: file of byte;ã lineNum: integer;ã line: string80;ã size,remaining :real;ãã procedure Abort(message: string80);ãã begin {abort}ã writeln;ã if lineNum > 0 then write('Line ', lineNum, ': ');ã writeln(message);ã haltã end; {Abort}ãã procedure NextLine(var s: string80);ãã begin {NextLine}ã LineNum := succ(LineNum);ã {write('.');}ã readln(infile, s);ã remaining:=remaining-length(s)-2; {-2 is for CR/LF}ã write('bytes remaining: ',remaining:7:0,' (',ã remaining/size*100.0:3:0,'%)',chr(13));ã end; {NextLine}ãã procedure Init;ãã procedure GetInFile;ãã VAR infilename: string80;ãã begin {GetInFile}ã if ParamCount = 0 then abort ('Usage: uudecode ');ã infilename := ParamStr(1);ã if pos('.', infilename) = 0ã then infilename := concat(infilename, defaultSuffix);ã assign(infile, infilename);ã {$i-}ã reset(infile);ã {$i+}ã if IOresult > 0 then abort (concat('Can''t open ', infilename));ã writeln ('Decoding ', infilename);ã assign(fi,infilename); reset(fi);ã size:=FileSize(fi); close(fi);ã if size < 0 then size:=size+65536.0;ã remaining:=size;ã end; {GetInFile}ãã procedure GetOutFile;ãã var header, mode, outfilename: string80;ã ch: char;ãã procedure ParseHeader;ãã VAR index: integer;ãã Procedure NextWord(var word:string80; var index: integer);ãã begin {nextword}ã word := '';ã while header[index] = ' ' doã beginã index := succ(index);ã if index > length(header) then abort ('Incomplete header')ã end;ã while header[index] <> ' ' doã beginã word := concat(word, header[index]);ã index := succ(index)ã endã end; {NextWord}ãã begin {ParseHeader}ã header := concat(header, ' ');ã index := 7;ã NextWord(mode, index);ã NextWord(outfilename, index)ã end; {ParseHeader}ãã begin {GetOutFile}ã if eof(infile) then abort('Nothing to decode.');ã NextLine (header);ã while not ((copy(header, 1, 6) = 'begin ') or eof(infile)) doã NextLine(header);ã writeln;ã if eof(infile) then abort('Nothing to decode.');ã ParseHeader;ã assign(outfile, outfilename);ã writeln ('Destination is ', outfilename);ã {$i-}ã reset(outfile);ã {$i+}ã if IOresult = 0 thenã beginã { write ('Overwrite current ', outfilename, '? [Y/N] ');ã repeatã read (kbd, ch);ã ch := UpCase(ch)ã until ch in ['Y', 'N'];ã writeln(ch);ã if ch = 'N' then abort ('Overwrite cancelled.')}ã end;ã rewrite (outfile);ã end; {GetOutFile}ãã begin {init}ã lineNum := 0;ã GetInFile;ã GetOutFile;ã end; { init}ãã Function CheckLine: boolean;ãã begin {CheckLine}ã if line = '' then abort ('Blank line in file');ã CheckLine := not (line[1] in [' ', '`'])ã end; {CheckLine}ããã procedure DecodeLine;ãã VAR lineIndex, byteNum, count, i: integer;ã chars: array [0..3] of byte;ã hunk: array [0..2] of byte;ãã{ procedure debug;ãã var i: integer;ãã procedure writebin(x: byte);ãã var i: integer;ãã beginã for i := 1 to 8 doã beginã write ((x and $80) shr 7);ã x := x shl 1ã end;ã write (' ')ã end;ãã beginã writeln;ã for i := 0 to 3 do writebin(chars[i]);ã writeln;ã for i := 0 to 2 do writebin(hunk[i]);ã writelnã end; }ãã function nextch: char;ãã begin {nextch}ã lineIndex := succ(lineIndex);ã if lineIndex > length(line) then abort('Line too short.');ã if not (line[lineindex] in [' '..'`'])ã then abort('Illegal character in line.');ã{ write(line[lineindex]:2);}ã if line[lineindex] = '`' then nextch := ' 'ã else nextch := line[lineIndex]ã end; {nextch}ãã procedure DecodeByte;ãã procedure GetNextHunk;ãã VAR i: integer;ãã begin {GetNextHunk}ã for i := 0 to 3 do chars[i] := ord(nextch) - offset;ã hunk[0] := (chars[0] shl 2) + (chars[1] shr 4);ã hunk[1] := (chars[1] shl 4) + (chars[2] shr 2);ã hunk[2] := (chars[2] shl 6) + chars[3];ã byteNum := 0 {;ã debug }ã end; {GetNextHunk}ãã begin {DecodeByte}ã if byteNum = 3 then GetNextHunk;ã write (outfile, hunk[byteNum]);ã {writeln(bytenum, ' ', hunk[byteNum]);}ã byteNum := succ(byteNum)ã end; {DecodeByte}ãã begin {DecodeLine}ã lineIndex := 0;ã byteNum := 3;ã count := (ord(nextch) - offset);ã for i := 1 to count do DecodeByteã end; {DecodeLine}ãã procedure terminate;ãã var trailer: string80;ãã begin {terminate}ã if eof(infile) then abort ('Abnormal end.');ã NextLine (trailer);ã if length (trailer) < 3 then abort ('Abnormal end.');ã if copy (trailer, 1, 3) <> 'end' then abort ('Abnormal end.');ã close (infile);ã close (outfile)ã end;ãã begin {uudecode}ã init;ã NextLine(line);ã while CheckLine doã beginã DecodeLine;ã NextLine(line)ã end;ã terminateã end.ãã 76 01-27-9412:24ALL PETER BEEFTINK UUEncode! IMPORT 38 oG {ã> Yeah ! Please post your UU(EN/DE)CODE here ! I am interested, as well !ããHere she goes then.ã}ããPROGRAM uuencode;ããUses Dos,Crt;ããCONSTã Header = 'begin';ã Trailer = 'end';ã DefaultMode = '644';ã DefaultExtension = '.uue';ã OFFSET = 32;ã CHARSPERLINE = 60;ã BYTESPERHUNK = 3;ã SIXBITMASK = $3F;ãTYPEã Str80 = STRING[80];ãVARã Infile: FILE OF Byte;ã Outfile: TEXT;ã Infilename, Outfilename, Mode: Str80;ã lineLength, numbytes, bytesInLine: INTEGER;ã Line: ARRAY [0..59] OF CHAR;ã hunk: ARRAY [0..2] OF Byte;ã chars: ARRAY [0..3] OF Byte;ã size,remaining : longint; {v1.1 REAL;}ãPROCEDURE Abort (Msg : Str80);ã BEGINã WRITELN(Msg);ã {$I-} {v1.1}ã CLOSE(Infile);ã CLOSE(Outfile);ã {$I+} {v1.1}ã HALTã END; {of Abort}ãPROCEDURE Init;ã PROCEDURE GetFiles;ã VARã i : INTEGER;ã TempS : Str80;ã Ch : CHAR;ã BEGINã IF ParamCount < 1 THEN Abort ('No input file specified.');ã Infilename := ParamStr(1);ã {$I-}ã ASSIGN (Infile, Infilename);ã RESET (Infile);ã {$I+}ã IF IOResult > 0 THEN Abort (CONCAT ('Can''t open file ', Infilename));ã size := FileSize(Infile);ã{ IF size < 0 THEN size:=size+65536.0; }ã remaining := size;ã WRITE('Uuencoding file ', Infilename);ã i := POS('.', Infilename);ã IF i = 0ã THEN Outfilename := Infilenameã ELSE Outfilename := COPY (Infilename, 1, PRED(i));ã Mode := DefaultMode;ã { Process 2d cmdline arg (if any).ã It could be a new mode (rather than default "644")ã or it could be a forced output name (rather thanã "infile.uue") }ã IF ParamCount > 1 {got more args}ã THEN FOR i := 2 TO ParamCount DO BEGINã TempS := ParamStr(i);ã IF TempS[1] IN ['0'..'9'] {numeric : it's a mode}ã THEN Mode := TempSã ELSE Outfilename := TempS {it's output filename}ã END;ã IF POS ('.', Outfilename) = 0 {he didn't give us extension..}ã {..so make it ".uue"}ã THEN Outfilename := CONCAT(Outfilename, DefaultExtension);ã ASSIGN (Outfile, Outfilename);ã WRITELN (' to file ', Outfilename, '.');ã {$I-}ã RESET(Outfile);ã {$I+}ã IF IOResult = 0 THEN BEGIN {output file exists!}ã WRITE ('Overwrite current ', Outfilename, '? [Y/N] ');ã REPEATã Ch := Upcase(ReadKey);ã UNTIL Ch IN ['Y', 'N'];ã WRITELN (Ch);ã IF Ch = 'N' THEN Abort(CONCAT (Outfilename, ' not overwritten.'))ã END;ã {$I-}ã CLOSE(Outfile);ã IF IOResult <> 0 THEN ; {v1.1 we don't care}ã REWRITE(Outfile);ã {$I+}ã IF IOResult > 0 THEN Abort(CONCAT('Can''t open ', Outfilename));ã END; {of GetFiles}ã BEGIN {Init}ã GetFiles;ã bytesInLine := 0;ã lineLength := 0;ã numbytes := 0;ã WRITELN (Outfile, Header, ' ', Mode, ' ', Infilename);ã END; {init}ã{You'll notice from here on we don't do any error-trapping on diskã read/writes. We just let DOS do the job. Any errors are terminalã anyway, right? }ãPROCEDURE FlushLine;ã VAR i: INTEGER;ã PROCEDURE WriteOut(Ch: CHAR);ã BEGINã IF Ch = ' ' THEN WRITE(Outfile, '`')ã ELSE WRITE(Outfile, Ch)ã END; {of WriteOut}ã BEGIN {FlushLine}ã {write ('.');}ã WRITE('bytes remaining: ',remaining:7,' (',ã remaining/size*100.0:3:0,'%)',CHR(13));ã WriteOut(CHR(bytesInLine + OFFSET));ã FOR i := 0 TO PRED(lineLength) DOã WriteOut(Line[i]);ã WRITELN (Outfile);ã lineLength := 0;ã bytesInLine := 0ã END; {of FlushLine}ãPROCEDURE FlushHunk;ã VAR i: INTEGER;ã BEGINã IF lineLength = CHARSPERLINE THEN FlushLine;ã chars[0] := hunk[0] ShR 2;ã chars[1] := (hunk[0] ShL 4) + (hunk[1] ShR 4);ã chars[2] := (hunk[1] ShL 2) + (hunk[2] ShR 6);ã chars[3] := hunk[2] AND SIXBITMASK;ã {debug;}ã FOR i := 0 TO 3 DO BEGINã Line[lineLength] := CHR((chars[i] AND SIXBITMASK) + OFFSET);ã {write(line[linelength]:2);}ã Inc(lineLength);ã END;ã {writeln;}ã Inc(bytesInLine,numbytes);ã numbytes := 0ã END; {of FlushHunk}ãPROCEDURE Encode1;ã BEGINã IF numbytes = BYTESPERHUNK THEN FlushHunk;ãã READ (Infile, hunk[numbytes]);ã Dec(remaining);ã Inc(numbytes);ã END; {of Encode1}ãPROCEDURE Terminate;ã BEGINã IF numbytes > 0 THEN FlushHunk;ã IF lineLength > 0 THEN BEGINã FlushLine;ã FlushLine;ã ENDã ELSE FlushLine;ã WRITELN (Outfile, Trailer);ã CLOSE (Outfile);ã CLOSE (Infile);ã END; {Terminate}ãBEGIN {uuencode}ã Init;ã WHILE NOT EOF (Infile) DO Encode1;ã Terminate;ã WRITELN;ãEND. {uuencode}ãã 77 01-27-9413:33ALL GREG ESTABROOKS String Timing Demo IMPORT 64 o¤Ü {$A+,B-,D-,E-,F-,I+,N-,O-,R-,S-,V+}ããprogram TestStringComp;ãusesã TpTimer; (* TurboPower's public domain TpTimer unit. *)ãã (* Run-Length-Encoded string compression. *)ã function fustRLEcomp(stIn : string) : string;ã varã byCount,ã byStInSize,ã byStTempPos : byte;ã woStInPos : word;ã stTemp : string;ã beginã fillchar(stTemp, sizeof(stTemp), 0);ã byCount := 1;ã byStTempPos := 1;ã woStInPos := 1;ã byStInSize := ord(stIn[0]);ã repeatã if (woStInPos < byStInSize)ã and (stIn[woStInPos] = stIn[succ(woStInPos)])ã and (byCount < $7F) thenã inc(byCount)ã elseã if (byCount > 3) thenã beginã stTemp[byStTempPos] := #0;ã stTemp[(byStTempPos + 1)] := chr(byCount);ã stTemp[(byStTempPos + 2)] := stIn[woStInPos];ã inc(stTemp[0], 3);ã inc(byStTempPos, 3);ã byCount := 1ã endã elseã beginã move(stIn[succ(woStInPos - byCount)],ã stTemp[byStTempPos], byCount);ã inc(stTemp[0], byCount);ã inc(byStTempPos, byCount);ã byCount := 1ã end;ã inc(woStInPos, 1)ã until (woStInPos > byStInSize);ã fustRLEcomp := stTempã end;ããã (* Run-Length-Encoded string expansion. *)ã function fustRLEexp(stIn : string) : string;ã varã byStInSize,ã byStTempPos : byte;ã woStInPos : word;ã stTemp : string;ã beginã fillchar(stTemp, sizeof(stTemp), 0);ã byStInSize := ord(stIn[0]);ã byStTempPos := 1;ã woStInPos := 1;ã repeatã if (stIn[woStInPos] <> #0) thenã beginã stTemp[byStTempPos] := stIn[woStInPos];ã inc(woStInPos, 1);ã inc(byStTempPos, 1);ã inc(stTemp[0], 1)ã endã elseã beginã fillchar(stTemp[byStTempPos], ord(stIn[succ(woStInPos)]),ã stIn[(woStInPos + 2)]);ã inc(byStTempPos, ord(stIn[succ(woStInPos)]));ã inc(stTemp[0], ord(stIn[succ(woStInPos)]));ã inc(woStInPos, 3)ã endã until (woStInPos > byStInSize);ã fustRLEexp := stTempã end;ããã (* 8 bit into 7 bit string compression. *)ã function fustComp87(stIn : string) : string;ã varã stTemp : string;ã byLoop, byTempSize, byOffset : byte;ã beginã if (stIn[0] < #255) thenã stIn[succ(ord(stIn[0]))] := #0;ã fillchar(stTemp, sizeof(stTemp), 0);ã byTempSize := ord(stIn[0]) shr 3;ã if ((ord(stIn[0]) mod 8) <> 0) thenã inc(byTempsize, 1);ã byOffset := 0;ã for byLoop := 1 to byTempSize doã beginã stTemp[(byOffset * 7) + 1] :=ã chr( ( (ord(stIn[(byOffset * 8) + 1]) and $7F) shl 1) +ã ( (ord(stIn[(byOffset * 8) + 2]) and $40) shr 6) );ã stTemp[(byOffset * 7) + 2] :=ã chr( ( (ord(stIn[(byOffset * 8) + 2]) and $3F) shl 2) +ã ( (ord(stIn[(byOffset * 8) + 3]) and $60) shr 5) );ã stTemp[(byOffset * 7) + 3] :=ã chr( ( (ord(stIn[(byOffset * 8) + 3]) and $1F) shl 3) +ã ( (ord(stIn[(byOffset * 8) + 4]) and $70) shr 4) );ã stTemp[(byOffset * 7) + 4] :=ã chr( ( (ord(stIn[(byOffset * 8) + 4]) and $0F) shl 4) +ã ( (ord(stIn[(byOffset * 8) + 5]) and $78) shr 3) );ã stTemp[(byOffset * 7) + 5] :=ã chr( ( (ord(stIn[(byOffset * 8) + 5]) and $07) shl 5) +ã ( (ord(stIn[(byOffset * 8) + 6]) and $7C) shr 2) );ã stTemp[(byOffset * 7) + 6] :=ã chr( ( (ord(stIn[(byOffset * 8) + 6]) and $03) shl 6) +ã ( (ord(stIn[(byOffset * 8) + 7]) and $7E) shr 1) );ã if (byOffset < 31) thenã stTemp[(byOffset * 7) + 7] :=ã chr( ( ( ord(stIn[(byOffset * 8) + 7]) and $01) shl 7) +ã ( ord(stIn[(byOffset * 8) + 8]) and $7F) )ã elseã stTemp[(byOffset * 7) + 7] :=ã chr( ( ord(stIn[(byOffset * 8) + 7]) and $01) shl 7);ã inc(byOffset, 1)ã end;ã stTemp[0] := chr(((ord(stIn[0]) div 8) * 7) + (ord(stIn[0]) mod 8) );ã fustComp87 := stTempã end;ããã (* 7 bit into 8 bit string expansion. *)ã function fustExp78(stIn : string) : string;ã varã stTemp : string;ã byOffset, byTempSize, byLoop : byte;ã beginã fillchar(stTemp, sizeof(stTemp), 0);ã byTempSize := ord(stIn[0]) div 7;ã if ((ord(stIn[0]) mod 7) <> 0)thenã inc(byTempSize, 1);ã byOffset := 0;ã for byLoop := 1 to byTempSize doã beginã stTemp[(byOffset * 8) + 1] :=ã chr( ord(stIn[(byOffset * 7) + 1]) shr 1);ã stTemp[(byOffset * 8) + 2] :=ã chr( ( ( ord(stIn[(byOffset * 7) + 1]) and $01) shl 6) +ã ( ( ord(stIn[(byOffset * 7) + 2]) and $FC) shr 2) );ã stTemp[(byOffset * 8) + 3] :=ã chr( ( ( ord(stIn[(byOffset * 7) + 2]) and $03) shl 5) +ã ( ord(stIn[(byOffset * 7) + 3]) shr 3) );ã stTemp[(byOffset * 8) + 4] :=ã chr( ( ( ord(stIn[(byOffset * 7) + 3]) and $07) shl 4) +ã ( ord(stIn[(byOffset * 7) + 4]) shr 4) );ã stTemp[(byOffset * 8) + 5] :=ã chr( ( ( ord(stIn[(byOffset * 7) + 4]) and $0F) shl 3) +ã ( ord(stIn[(byOffset * 7) + 5]) shr 5) );ã stTemp[(byOffset * 8) + 6] :=ã chr( ( ( ord(stIn[(byOffset * 7) + 5]) and $1F) shl 2) +ã ( ord(stIn[(byOffset * 7) + 6]) shr 6) );ã stTemp[(byOffset * 8) + 7] :=ã chr( ( ( ord(stIn[(byOffset * 7) + 6]) and $3F) shl 1) +ã ( ord(stIn[(byOffset * 7) + 7]) shr 7) );ã if (byOffset < 31) thenã stTemp[(byOffset * 8) + 8] :=ã chr( (ord(stIn[(byOffset * 7) + 7]) and $7F) );ã inc(byOffset, 1)ã end;ã stTemp[0] :=ã chr( ( (ord(stIn[0]) div 7) * 8) + (ord(stIn[0]) mod 7) );ã if (stTemp[ord(stTemp[0])] = #0) thenã dec(stTemp[0], 1);ã fustExp78 := stTempã end;ãããvarã loStart, loStop : longint;ãã stMy1,ã stMy2,ã stMy3 : string;ãã (* Main program execution block. *)ãBEGINãã (* Test string 1. *)ã stMy1 := '12345678901111111111123456789022222222221234567890' +ã '33333333331234567890444444444412345678905555555555' +ã '12345678906666666666123456789077777777771234567890' +ã '88888888881234567890999999999912345678900000000000' +ã '1234567890AAAAAAAAAA1234567890BBBBBBBBBB1234567890' +ã 'CCCCC';ãã (* Test string 2. *)ã{ stMy1 := '12345678901234567890123456789012345678901234567890' +ã '12345678901234567890123456789012345678901234567890' +ã '12345678901234567890123456789012345678901234567890' +ã '12345678901234567890123456789012345678901234567890' +ã '12345678901234567890123456789012345678901234567890' +ã '12345'; }ãã (* Test string 3. *)ã{ stMy1 := '11111111111111111111111111111111111111111111111111' +ã '11111111111111111111111111111111111111111111111111' +ã '11111111111111111111111111111111111111111111111111' +ã '11111111111111111111111111111111111111111111111111' +ã '11111111111111111111111111111111111111111111111111' +ã '11111'; }ãã loStart := ReadTimer;ã stMy2 := fustComp87(fustRLEcomp(stMy1));ã loStop := ReadTimer;ã writeln(' Time to compress = ', ElapsedTimeString(loStart, loStop), ' ms');ã loStart := ReadTimer;ã stMy3 := fustRLEexp(fustExp78(stMy2));ã loStop := ReadTimer;ã writeln(' Time to expand = ', ElapsedTimeString(loStart, loStop), ' ms');ã writeln;ã writeln(stMy1);ã writeln;ã writeln(stMy2);ã writeln;ã writeln(stMy3);ã writeln;ã if (stMy1 <> stMy3) thenã writeln(' Conversion Error')ã elseã writeln(' Conversion Match')ãEND.ããã 78 01-27-9413:34ALL GREG ESTABROOKS Misc Utilities IMPORT 83 oô: UNIT Utils; { Misc Utilities Last Updates Nov 01/93 }ã { Copyright (C) 1992,93 Greg Estabrooks }ããINTERFACEã{ *********************************************************************}ãUSESã CRT,KeyIO,DOS;ããCONSTã FpuType :ARRAY[0..3] OF STRING[10] =('None','8087','80287','80387');ã CPU :ARRAY[0..3] Of STRING[13] =('8088/V20','80286',ã '80386/80486','80486');ãCONST { Define COM port Addresses }ã ComPort :ARRAY[1..4] Of WORD = ($3F8,$2F8,$3E8,$2E8);ããCONSTã Warm :WORD = 0000; { Predefined value for warm boot. }ã Cold :WORD = 0001; { Predefined value for cold boot. }ããVARã BiosDate :ARRAY[0..7] of CHAR Absolute $F000:$FFF5;ã EquipFlag :WORD Absolute $0000:$0410;ã CompID :BYTE Absolute $F000:$FFFE;ããFUNCTION CoProcessorExist :BOOLEAN;ãFUNCTION NumPrinters :WORD;ãFUNCTION GameIOAttached :BOOLEAN;ãFUNCTION NumSerialPorts :INTEGER;ãFUNCTION NumDisketteDrives :INTEGER;ãFUNCTION InitialVideoMode :INTEGER;ãPROCEDURE Noise(Pitch, Duration :INTEGER);ãFUNCTION Time :STRING;ãFUNCTION WeekDate :STRING;ãFUNCTION DayOfWeek( Month, Day, Year :WORD ) :BYTE; { Returns 1-7 }ãFUNCTION PrinterOK :BOOLEAN;ãFUNCTION AdlibCard :BOOLEAN;ãFUNCTION TrueDosVer :WORD;ãPROCEDURE SetPrtScr( On_OFF :BOOLEAN );ãFUNCTION CpuType :WORD;ãPROCEDURE IdePause;ãFUNCTION RingDetect( CPort :WORD) :BOOLEAN;ãfunction DetectOs2: Boolean;ãFUNCTION HiWord( Long :LONGINT ) :WORD;ã { Routine to return high word of a LongInt. }ãFUNCTION LoWord( Long :LONGINT ) :WORD;ã { Routine to return low word of a LongInt. }ãFUNCTION Running4DOS : Boolean;ãPROCEDURE Reboot( BootCode :WORD );ã { Routine to reboot system according to boot code.}ãããFUNCTION GetChar( X,Y :WORD; VAR Attrib:BYTE ) :CHAR;ããIMPLEMENTATIONã{ *********************************************************************}ãFUNCTION CoProcessorExist :BOOLEAN;ãBEGINã CoProcessorExist := (EquipFlag And 2) = 2;ãEND;ããFUNCTION NumPrinters :WORD;ãBEGINã NumPrinters := EquipFlag Shr 14;ãEND;ããFUNCTION GameIOAttached :BOOLEAN;ãBEGINã GameIOAttached := (EquipFlag And $1000) = 1;ãEND;ããFUNCTION NumSerialPorts :INTEGER;ãBEGINã NumSerialPorts := (EquipFlag Shr 9) And $07;ãEND;ããFUNCTION NumDisketteDrives :INTEGER;ãBEGINã NumDisketteDrives := ((EquipFlag And 1) * (1+(EquipFlag Shr 6) And $03));ãEND;ããFUNCTION InitialVideoMode :INTEGER;ãBEGINã InitialVideoMode := (EquipFlag Shr 4) And $03;ãEND;ããPROCEDURE Noise( Pitch, Duration :INTEGER );ãBEGINã Sound(Pitch);ã Delay(Duration);ã NoSound;ãEND;ããFunction Time : String;ãVARã Hour,Min,Sec :STRING[2];ã H,M,S,T :WORD;ããBEGINã GetTime(H,M,S,T);ã Str(H,Hour);ã Str(M,Min);ã Str(S,Sec);ã If S < 10 Thenã Sec := '0' + Sec;ã If M < 10 Thenã Min := '0' + Min;ã If H > 12 Thenã BEGINã Str(H - 12, Hour);ã IF Length(Hour) = 1 Then Hour := ' ' + Hour;ã Time := Hour + ':' + Min + ':' + Sec+' pm'ã ENDã ELSEã BEGINã If H = 0 Thenã Time := '12:' + Min + ':' + Sec + ' am'ã ELSEã Time := Hour +':'+Min+':'+Sec+' am';ã END;ã If H = 12 Thenã Time := Hour + ':' + Min + ':' + Sec + ' pm';ãEND;ããFUNCTION WeekDate :STRING;ã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');ãVARã Y,ã M,ã D,ã DayOfWeek :WORD;ã Year :STRING;ã Day :STRING;ããBEGINã GetDate(Y,M,D,DayofWeek);ã Str(Y,Year);ã Str(D,Day);ã WeekDate := DayNames[DayOfWeek] + ' ' + MonthNames[M] + ' ' + Day+ ', 'ã + Year;ãEND;ããFUNCTION DayOfWeek( Month, Day, Year :WORD ) :BYTE;ãVAR ivar1, ivar2 : Integer;ãBEGINã IF (Day > 0) AND (Day < 32) AND (Month > 0) AND (Month < 13)ã THENã BEGINã ivar1 := ( Year MOD 100 );ã ivar2 := Day + ivar1 + ivar1 DIV 4;ã CASE Month OFã 4, 7 : ivar1 := 0;ã 1, 10 : ivar1 := 1;ã 5 : ivar1 := 2;ã 8 : ivar1 := 3;ã 2,3,11 : ivar1 := 4;ã 6 : ivar1 := 5;ã 9,12 : ivar1 := 6;ã END; {case}ã ivar2 := ( ivar1 + ivar2 ) MOD 7;ã IF ( ivar2 = 0 ) THEN ivar2 := 7;ã END {IF}ã ELSEã ivar2 := 0;ã DayOfWeek := BYTE( ivar2 );ãEND;ããFUNCTION PrinterOK :BOOLEAN;ã { Determine whether printer is on or off line }ãBEGINã If (Port[$379]) And (16) <> 16 Thenã PrinterOK := Falseã Elseã PrinterOK := True;ãEND;ããFUNCTION AdlibCard :BOOLEAN;ã { Routine to determine if a Adlib compatible card is installed }ãVARã Val1,Val2 :BYTE;ãBEGINã Port[$388] := 4; { Write 60h to register 4 }ã Delay(3); { Which resets timer 1 and 2 }ã Port[$389] := $60;ã Delay(23);ã Port[$388] := 4; { Write 80h to register 4 }ã Delay(3); { Which enables interrupts }ã Port[$389] := $80;ã Delay(23);ã Val1 := Port[$388]; { Read status byte }ã Port[$388] := 2; { Write ffh to register 2 }ã Delay(3); { Which is also Timer 1 }ã Port[$389] := $FF;ã Delay(23);ã Port[$388] := 4; { Write 21h to register 4 }ã Delay(3); { Which will Start Timer 1 }ã Port[$389] := $21;ã Delay(85); { wait 85 microseconds }ã Val2 := Port[$388]; { read status byte }ã Port[$388] := 4; { Repeat the first to steps }ã Delay(3); { Which will reset both Timers }ã Port[$389] := $60;ã Delay(23);ã Port[$388] := 4;ã Delay(3);ã Port[$389] := $80; { Now test the status bytes saved }ã If ((Val1 And $E0) = 0) And ((Val2 And $E0) = $C0) Thenã AdlibCard := True { Card was found }ã Elseã AdlibCard := False; { No Card Installed }ãEND;ããFUNCTION TrueDosVer :WORD; ASSEMBLER;ã { Returns true Dos Version. Not affected by Setver }ãASMã Mov AX,$3306 { get true dos ver }ã Int $21 { Call Dos }ã Mov AX,BX { Return proper results }ãã { DL = Revision Number }ã { DH = V Flags, 8h = Dos in ROM, 10h Dos in HMA }ãEND;{TrueDosVer}ããPROCEDURE SetPrtScr( On_OFF :BOOLEAN );ã { Routine to Enable or disable Print screen key }ãBEGINã If On_OFF Then { Turn it on }ã Mem[$0050:0000] := 0ã Elseã Mem[$0050:0000] := 1; { Turn it off }ãEND;ããFUNCTION CpuType :WORD; ASSEMBLER;ã { Returns a value depending on the type of CPU }ã { 0 = 8088/V20 or compatible }ã { 1 = 80286 2 = 80386/80486+ }ãASMã Xor DX,DX { Clear DX }ã Push DXã PopF { Clear Flags }ã PushFã Pop AX { Load Cleared Flags }ã And AX,$0F000 { Check hi bits for F0h }ã Cmp AX,$0F000ã Je @Quit { Quit if 8088 }ã Inc DXã Mov AX,$0F000 { Now Check For 80286 }ã Push AXã PopFã PushFã Pop AXã And AX,$0F000 { If The top 4 bits aren't set }ã Jz @Quit { Its a 80286+ }ã Inc DX { Else its a 80386 or better }ã@Quit:ã Mov AX,DX { Return Result in AX }ãEND;{CpuType}ããprocedure idepause;ãbeginã gotoxy(1,25);ã write('Press any key to return to IDE');ã pausekey;ãend;ããFUNCTION RingDetect( CPort :WORD) :BOOLEAN;ã { Routine to detect whether or not the }ã { phone is ringing by checking the comport}ãBEGINã RingDetect := ODD( PORT[CPort] SHR 6 );ãEND;ããfunction DetectOs2: Boolean;ãbeginã { if you use Tpro, then write Hi(TpDos.DosVersion) }ã DetectOs2 := (Lo(Dos.DosVersion) > 10);ãend;ããFUNCTION HiWord( Long :LONGINT ) :WORD; ASSEMBLER;ã { Routine to return high word of a LongInt. }ãASMã Mov AX,Long.WORD[2] { Move High word into AX. }ãEND;ããFUNCTION LoWord( Long :LONGINT ) :WORD; ASSEMBLER;ã { Routine to return low word of a LongInt. }ãASMã Mov AX,Long.WORD[0] { Move low word into AX. }ãEND;ããFUNCTION Running4DOS : Boolean;ãVAR Regs : Registers;ãbeginã With Regs doã beginã ax := $D44D;ã bx := $00;ã end;ã Intr ($2F, Regs);ã if Regs.ax = $44DD then Running4DOS := TRUEã else Running4DOS := FALSEãend;ããPROCEDURE Reboot( BootCode :WORD );ã { Routine to reboot system according to boot code.}ã { Also flushes all DOS buffers. }ã { NOTE: Doesn't update directory entries. }ãBEGINã Inline(ã $BE/$0D/ { MOV AH,0Dh }ã $CD/$21/ { INT 21h }ã $FB/ { STI }ã $B8/Bootcode/ { MOV AX,BootCode }ã $8E/$D8/ { MOV DS,AX }ã $B8/$34/$12/ { MOV AX,1234h }ã $A3/$72/$04/ { MOV [0472h],AX }ã $EA/$00/$00/$FF/$FF); { JMP FFFFh:0000h }ãEND;ãããFUNCTION GetChar( X,Y :WORD; VAR Attrib:BYTE ) :CHAR;ã { Retrieves the character and attribute of }ã { coordinates X,Y. }ãVARã Ofs :WORD;ãBEGINã Ofs := ((Y-1) * 160) + ((X SHL 1) - 1);ã Attrib := MEM[$B800:Ofs];ã GetChar := CHR( MEM[$B800:Ofs-1] );ãEND;ãããBEGINãEND. 79 01-27-9417:29ALL GAYLE DAVIS Loan Amortization Tables IMPORT 30 oâ program Amortization_Table;ããUses Crt,Printer;ããvar Month : 1..12;ã Starting_Month : 1..12;ã Balance : real;ã Payment : real;ã Interest_Rate : real;ã Annual_Accum_Interest : real;ã Year : integer;ã Number_Of_Years : integer;ã Original_Loan : real;ãããprocedure Calculate_Payment; (* **************** calculate payment *)ãvar Temp : real;ã Index : integer;ãbeginã Temp := 1.0;ã for Index := 1 to 12*Number_Of_Years doã Temp := Temp * (1.0 + Interest_Rate);ã Payment := Original_Loan*Interest_Rate/(1.0 - 1.0/Temp);ãend;ããprocedure Initialize_Data; (* ******************** initialize data *)ãbeginã Writeln(' Pascal amortization program');ã Writeln;ã Write('Enter amount borrowed ');ã Readln(Original_Loan);ã Balance := Original_Loan;ã Write('Enter interest rate as percentage (i.e. 13.5) ');ã Readln(Interest_Rate);ã Interest_Rate := Interest_Rate/1200.0;ã Write('Enter number of years of payoff ');ã Readln(Number_Of_Years);ã Write('Enter month of first payment (i.e. 5 for May) ');ã Readln(Starting_Month);ã Write('Enter year of first payment (i.e. 1994) ');ã Readln(Year);ã Calculate_Payment;ã Annual_Accum_Interest := 0.0; (* This is to accumulate Interest *)ãend;ããprocedure Print_Annual_Header; (* ************ print annual header *)ãbeginã Writeln;ã Writeln;ã Writeln('Original loan amount = ',Original_Loan:10:2,ã ' Interest rate = ',1200.0*Interest_Rate:6:2,'%');ã Writeln;ã Writeln('Month payment interest princ balance');ã Writeln;ã Writeln(Lst);ã Writeln(Lst);ã Writeln(Lst,'Original loan amount = ',Original_Loan:10:2,ã ' Interest rate = ',1200.0*Interest_Rate:6:2,'%');ã Writeln(Lst);ã Writeln(Lst,'Month payment interest princ balance');ã Writeln(Lst);ãend;ããprocedure Calculate_And_Print; (* ************ calculate and print *)ãvar Interest_Payment : real;ã Principal_Payment : real;ãbeginã if Balance > 0.0 then beginã Interest_Payment := Interest_Rate * Balance;ã Principal_Payment := Payment - Interest_Payment;ã if Principal_Payment > Balance then begin (* loan payed off *)ã Principal_Payment := Balance; (* this month *)ã Payment := Principal_Payment + Interest_Payment;ã Balance := 0.0;ã endã else begin (* regular monthly payment *)ã Balance := Balance - Principal_Payment;ã end;ã Annual_Accum_Interest := Annual_Accum_Interest+Interest_Payment;ã Writeln(Month:5,Payment:10:2,Interest_Payment:10:2,ã Principal_Payment:10:2,Balance:10:2);ã Writeln(Lst,Month:5,Payment:10:2,Interest_Payment:10:2,ã Principal_Payment:10:2,Balance:10:2);ã end; (* of if Balance > 0.0 then *)ãend;ããprocedure Print_Annual_Summary; (* ********** print annual summary *)ãbeginã Writeln;ã Writeln('Total interest for ',Year:5,' = ',ã Annual_Accum_Interest:10:2);ã Writeln;ã Writeln(Lst);ã Writeln(Lst,'Total interest for ',Year:5,' = ',ã Annual_Accum_Interest:10:2);ã Annual_Accum_Interest := 0.0;ã Year := Year + 1;ã Writeln(Lst);ãend;ããbegin (* ******************************************* main program *)ã Clrscr;ã Initialize_Data;ã repeatã Print_Annual_Header;ã for Month := Starting_Month to 12 do beginã Calculate_And_Print;ã end;ã Print_Annual_Summary;ã Starting_Month := 1;ã until Balance <= 0.0;ãend. (* of main program *)ã 80 01-27-9417:33ALL GAYLE DAVIS English Number Strings IMPORT 25 oí {$S-,R-,V-,I-,N-,B-,F-}ãã{ã Converts REAL number to ENGLISH stringsã GAYLE DAVIS 1/21/94ã Amounts up to and including $19,999,999.99 are supported.ã If you write amounts larger than that, you don't need a computer !!ã ======================================================================ã Dedicated to the PUBLIC DOMAIN, this software code has been tested andã used under BP 7.0/DOS and MS-DOS 6.2.ã}ãã{$IFNDEF Ver40}ã {Allow overlays}ã {$F+,O-,X+,A-}ã{$ENDIF}ããUSES CRT;ããCONSTã Dot : CHAR = #42;ããVARã SS : STRING;ã AA : REAL;ããFUNCTION EnglishNumber (Amt : REAL) : STRING;ããTYPEã Mword = STRING [10];ã Amstw = STRING [80]; {for function TenUnitToWord output}ããCONSTã NumStr : ARRAY [0..27] OF Mword =ã ('', 'ONE ', 'TWO ', 'THREE ', 'FOUR ', 'FIVE ', 'SIX ', 'SEVEN ',ã 'EIGHT ','NINE ', 'TEN ', 'ELEVEN ', 'TWELVE ', 'THIRTEEN ',ã 'FOURTEEN ', 'FIFTEEN ', 'SIXTEEN ', 'SEVENTEEN ', 'EIGHTEEN ',ã 'NINETEEN ', 'TWENTY ', 'THIRTY ', 'FORTY ', 'FIFTY ', 'SIXTY ',ã 'SEVENTY ', 'EIGHTY ', 'NINETY ');ãVARã S : STRING;ã Temp : REAL;ã DigitA, DigitB : INTEGER;ã Ams : STRING;ã Ac : STRING [2];ããFUNCTION TenUnitToWord (TeUn : INTEGER) : Amstw;ã { convert tens and units to words }ã BEGINã IF TeUn < 21 THEN TenUnitToWord := NumStr [TeUn]ã ELSE TenUnitToWord := NumStr [TeUn DIV 10 + 18] + NumStr [TeUn MOD 10];ã END; {function TenUnitToWord}ããBEGINãã { Nothing bigger than 20 million }ã IF (Amt > 20000000.0) OR (Amt <= 0.0) THENã BEGINã EnglishNumber := ''; {null string if out of range}ã EXIT;ã END;ã { Convert 1,000,000 decade }ã Ams := '';ã DigitA := TRUNC (Amt / 1E6);ã IF DigitA > 0 THEN Ams := Ams + NumStr [DigitA] + 'MILLION ';ã Temp := Amt - DigitA * 1E6;ãã { Convert 100,000, 10,000, 1,000 decades }ãã DigitA := TRUNC (Temp / 1E5); {extract 100,000 decade}ã IF DigitA > 0 THEN Ams := Ams + NumStr [DigitA] + 'HUNDRED ';ã Temp := Temp - DigitA * 1E5;ã DigitB := TRUNC (Temp / 1000); {extract sum of 10,000 and 1,000 decades}ã Ams := Ams + TenUnitToWord (DigitB);ã IF ( (DigitA > 0) OR (DigitB > 0) ) THEN Ams := Ams + 'THOUSAND ';ãã {Convert 100, 10, unit decades}ãã Temp := Temp - DigitB * 1000.0;ã DigitA := TRUNC (Temp / 100); {extract 100 decade}ã IF DigitA > 0 THEN Ams := Ams + NumStr [DigitA] + 'HUNDRED ';ã DigitB := TRUNC (Temp - DigitA * 100.0); {extract sum of 10 and unit decades}ã Ams := Ams + TenUnitToWord (DigitB);ãã {Convert cents to form XX/100}ãã IF INT (Amt) > 0.0 THEN Ams := Ams + 'AND ';ã DigitA := ROUND ( (FRAC (Amt) * 100) );ã IF DigitA > 0 THENã BEGINã STR (DigitA : 2, Ac);ã IF Ac [1] = ' ' THEN Ac [1] := '0';ã Ams := Ams + Ac + '/100'ã ENDã ELSE Ams := Ams + 'NO/100';ãã EnglishNumber := Ams + ' Dollars';ããEND;ããBEGINãClrScr;ãWriteLn(EnglishNumber (1234.55));ãWriteLn(EnglishNumber (991234.55));ãWriteLn(EnglishNumber (19891234.55));ãReadkey;ãEND.ã 81 01-27-9417:36ALL SWAG SUPPORT TEAM Info on DBASE3 Files IMPORT 108 oå{ Unit dbfinfo;ãinterfaceãusesã crt;ããvarã dbfile : file;ã currentrec : longint;ã dbfilename : string;ã dbfileok : boolean;ã dberr : integer;ãããprocedure dbwrthd; {writes the header info}ãprocedure disprec; {displays the record data}ãprocedure dbhdrd; {reads the header info}ãprocedure waitforkey; {waits for key to be hit}ããimplementationãconstã dbmaxflds = 128; {max. number of fields }ã dbmaxrecsize = 4000; {max. size of a record }ãããTypeãã DBfileinfo = record { first 32 bytes of DBF }ã version : byte;ã year : byte;ã month : byte;ã day : byte;ã norecord : longint;ã headlen : integer;ã reclen : integer;ã res : array[1..20] of byte;ã end;ãã DBfieldinfo = record { 32 byte field info }ã name : array[1..11] of char;ã ftype : byte;ã addr : longint;ã len : byte;ã dcnt : byte;ã res : array[1..14] of char;ã end;ãã dbfldar = array[1..dbmaxflds] of dbfieldinfo;ã dbrecar = array[1..dbmaxrecsize] of char;ããvarã dbhead : dbfileinfo;ã dbfield : dbfldar;ã dbnofld : integer;ã dbrecord : dbrecar;ãããprocedure waitforkey;ãvarã junk : char;ãbeginã writeln;ã write('Hit any key to continue');ã junk := readkey;ãend;ããã{ read rdbase III header info }ã{ blockread error - dberr = h = 0, l = number of records read}ã{ bad header - dberr - h = 1, l = version }ãprocedure dbhdrd;ãvarã i : integer;ãbeginã blockread(dbfile,dbhead,32,dberr);ã dbfileok := (dberr = 32);ã dbnofld := (dbhead.headlen - 33) div 32;ã if not dbfileok then exit;ãã if not ((dbhead.version = $83) or (dbhead.version = $03)) thenã beginã dbfileok := false;ã dberr := dbhead.version or $100;ã exit;ã end;ãã for i := 1 to dbnofld doã beginã blockread(dbfile,dbfield[i],32,dberr);ã dbfileok := (dberr = 32);ã if not dbfileok then exit;ã end;ããend;ãã{ writes field titles on screen }ãprocedure dbwrfldtit(line : integer);ãbeginã gotoxy(1,line);ã write('Field Name Type Len Dec');ã gotoxy(40,line);ã writeln('Field Name Type Len Dec');ã write('-----------------------------------------------------------------');ãend;ããã{ writes all header info to the screen }ãprocedure dbwrthd;ãvarã line,j,i : integer;ããbeginã clrscr;ã gotoxy(29,1);ã write('DBase file ',dbfilename);ã gotoxy(1,3);ã with dbhead doã beginã write('Last Time File Updated - ',month:2,'/',day:2,'/',year:2);ã gotoxy(40,3);ã write('Number of records in file - ',norecord);ã gotoxy(1,4);ã write('Length of each record - ',reclen);ã gotoxy(40,4);ã end;ã write('Number of fields - ',dbnofld);ã dbwrfldtit(6);ã line := 8;ã for i := 1 to dbnofld doã beginã if odd(i) then gotoxy(1,line) else gotoxy(40,line);ã with dbfield[i] doã beginã for j := 1 to 11 do write(name[j]);ã write(' ',chr(ftype),' ',len:3,' ',dcnt:3);ã end;ã if not odd(i) thenã beginã line := succ(line);ã if line = 24 thenã beginã if i < dbnofld thenã beginã line := 3;ã writeln;ã write('More ....');ã waitforkey;ã clrscr;ã dbwrfldtit(1);ã end;ã end;ã end;ã end;ã waitforkey;ãend;ãã{ read and display a DBase III record }ã{ if field data is larger than one line if will be truncated }ããprocedure dbreadrec(rec : longint);ãconstã maxchar = 65; {maximum characters to display from record}ãvarã temp : longint;ã i,j,stoppos,startpos,maxlen : integer;ã linecnt : integer;ããbeginã with dbhead doã beginã if (rec < 1) or (rec > norecord) thenã beginã dberr := 0;ã dbfileok := false;ã exit;ã end;ã temp := rec;ã rec := (rec - 1) * reclen + headlen;ã seek(dbfile,rec);ã blockread(dbfile,dbrecord,reclen,dberr);ã end;ã clrscr;ã write('DBASE file ',dbfilename,' Record No. ',temp);ã if dbrecord[1] = '*' then writeln(' DELETED') else writeln;ã writeln;ã startpos := 2;ã linecnt := 1;ã for i := 1 to dbnofld doã beginã with dbfield[i] doã beginã for j := 1 to 11 do write(name[j]);ã write(' -- ');ã if len > maxchar then maxlen := maxcharã else maxlen := len;ã stoppos := startpos + maxlen;ã for j := startpos to stoppos -1 do write(dbrecord[j]);ã startpos := startpos + len;ã writeln;ã linecnt := succ(linecnt);ã if linecnt = 22 thenã beginã if i < dbnofld thenã beginã linecnt := 1;ã write('More ....');ã waitforkey;ã for j := 3 to 25 doã beginã gotoxy(1,j);ã clreol;ã end;ã gotoxy(1,3);ã end;ã end;ã end;ã end;ã waitforkey;ãend;ããprocedure disprec;ãvarã rec : string;ã treal : real;ã error : integer;ããbeginã repeatã clrscr;ã writeln('DBASE file -- ',dbfilename);ã writeln;ã write('Total records = ',dbhead.norecord);ã writeln(' Current Record = ',currentrec);ã writeln;ã write('Enter record to display (0 = exit, cr = next, - = previous)? ');ã readln(rec);ã if (rec = '') or (rec[1] = '-') thenã beginã if rec = '' then currentrec := succ(currentrec)ã elseã currentrec := pred(currentrec);ã endã elseã beginã val(rec,treal,error);ã if error <> 0 then treal := 0.0;ã currentrec := trunc(treal);ã end;ã if currentrec = 0 then exit;ã if currentrec < 0 then currentrec := 1;ã if currentrec > dbhead.norecord then currentrec := dbhead.norecord;ã dbreadrec(currentrec);ã until falseããend;ãbeginãend.ãã Dbase III DBF File StructureãããHeaderã------ããã ãBYTE # Type Example Descriptionã------ ---- ------- -----------ã ã0 Byte 1 DBASE Versionã (83H with DBT file)ã (03H without DBT file)ãã1 Byte 2 Year - Binaryãã2 Byte 3 Month - Binaryãã3 Byte 4 Day - Binaryãã4-7 32 bit integer 5 Number of records in fileãã8-9 16 bit integer 6 Length of headerãã10-11 16 bit integer 7 Length of recordãã12-31 20 Bytes 8 Reservedãã32-n 32 Bytes Field Descriptorã (See below)ã ãn+1 Byte 9 0Dh field terminatorããN+2 Byte 10 00h In some older versionsã (The length of header byteã reflects this if present)ã.paããField Descriptorã----------------ããBYTE # Type Example Descriptionã------ ---- ------- -----------ãã0-10 byte 11 Field name ã (Zero filled)ãã11 Byte 12 Field Typeã (N D L C M)ãã12-15 32 bit integer 13 Field data addressã (Internal use)ãã16 Byte 14 Field length - Binaryãã17 Byte 15 Field decimal count - Binaryãã18-31 14 bytes 16 ReservedããããField Typesã-----------ãããN Numeric - 0 1 2 3 4 5 6 7 8 . -ãããD Date - 8 Bytes (YYYYMMDD)ãããL Logical - Y y N n T t F f ? (? = Not initialized)ãããC Character - Any Ascii CharacterãããM Memo - 10 digits (DBT block Number)ããããData Recordsã------------ããã All data is in Ascii.ããã There is no field seperators or record terminators.ãã The first byte is a space (20h) if record not deleted and anã asterick (2AH) if deleted.ããããDBASE Limitationsã-----------------ããFields - 128 Max.ããRecord - 4000 bytes Max.ããHeader - 4130 bytes Max.ãã (128 Fields * 32 bytes) + 32 bytes + 1 terminator + (1 null)ããNumber - 19 digitsãããããExample Fileã------------ããã 1 2 3 4 5 6 7 8ã || || || || |---------| |---| |---| |---------- ã000000 83 55 0B 0E 31 00 00 00-81 01 89 00 00 00 00 00 .U..1...........ãã ----------------------------------------------|ã000010 00 00 00 00 00 00 00 00-00 00 00 00 00 00 00 00 ................ãã 11 12 13ã |------------------------------| || |---------| ã000020 46 49 52 53 54 4E 41 4D-45 00 00 43 13 01 9D 41 FIRSTNAME..C...Aãã 14 15 16ã || || |---------------------------------------|ã000030 14 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã000040 4C 41 53 54 4E 41 4D 45-00 00 00 43 27 01 9D 41 LASTNAME...C'..Aãã000050 14 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã000060 50 48 4F 4E 45 00 00 00-00 00 00 43 3B 01 9D 41 PHONE......C;..Aãã000070 0D 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã000080 54 52 41 56 45 4C 43 4F-44 45 00 43 48 01 9D 41 TRAVELCODE.CH..Aãã000090 04 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã0000A0 54 52 41 56 45 4C 50 4C-41 4E 00 43 4C 01 9D 41 TRAVELPLAN.CL..Aãã0000B0 28 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 (...............ãã0000C0 44 45 50 41 52 54 55 52-45 00 00 44 74 01 9D 41 DEPARTURE..Dt..Aãã0000D0 08 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã0000E0 43 4F 53 54 00 50 41 49-44 00 00 4E 7C 01 9D 41 COST.PAID..N|..Aãã0000F0 0A 02 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã000100 50 41 49 44 00 4F 54 45-53 00 00 4C 86 01 9D 41 PAID.OTES..L...Aãã000110 01 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã000120 41 47 45 4E 54 00 00 00-00 00 00 43 87 01 9D 41 AGENT......C...Aãã000130 02 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã000140 52 45 53 45 52 56 44 41-54 45 00 44 89 01 9D 41 RESERVDATE.D...Aãã000150 08 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã000160 4E 4F 54 45 53 00 00 00-00 00 00 4D 91 01 9D 41 NOTES......M...Aãã000170 0A 00 00 00 01 00 00 00-00 00 00 00 00 00 00 00 ................ãã Firstnameã || |----------------------------------------ã000180 0D 20 43 6C 61 69 72 65-20 20 20 20 20 20 20 20 . Claire ã ã Lastnameã ----------------| |----------------------------ã000190 20 20 20 20 20 20 42 75-63 6B 6D 61 6E 20 20 20 Buckman ãã Phoneã ----------------------------| |----------------ã0001A0 20 20 20 20 20 20 20 20-20 20 28 35 35 35 29 34 (555)4ãã T - code T - planã -------------------| |---------| |-------------ã0001B0 35 36 2D 39 30 35 39 43-49 31 30 31 30 2D 6E 69 56-9059CI1010-niãã -----------------------------------------------ã0001C0 67 68 74 20 43 61 72 69-62 62 65 61 6E 20 49 73 ght Caribbean Isãã -----------------------------------------------ã0001D0 6C 61 6E 64 20 43 72 75-69 73 65 20 20 20 20 20 land Cruise ãã Departure Date Costã -------| |---------------------| |------------- ã0001E0 20 20 20 31 39 38 35 31-30 32 34 20 20 20 31 31 19851024 11ãã PD Age Res. Dateã -------------| || |---| |---------------------|ã0001F0 39 39 2E 30 30 54 4D 4D-31 39 38 35 30 37 31 35 99.00TMM19850715ãã.paã Notesã |---------------------------|ã000200 20 20 20 20 20 20 20 20-20 31 20 52 69 63 6B 20 1 Rick ãã000210 20 20 20 20 20 20 20 20-20 20 20 20 20 20 20 4C Lãã000220 69 73 62 6F 6E 6E 20 20-20 20 20 20 20 20 20 20 isbonn ãã000230 20 20 20 28 35 35 35 29-34 35 35 2D 33 33 34 34 (555)455-3344ãã000240 41 56 31 30 39 2D 6E 69-67 68 74 20 41 6C 61 73 AV109-night Alasãã000250 6B 61 2F 56 61 6E 63 6F-75 76 65 72 20 43 72 75 ka/Vancouver Cruãã000260 69 73 65 20 20 20 20 20-20 20 20 20 31 39 38 35 ise 1985ãã000270 30 38 30 35 20 20 20 31-33 37 38 2E 30 30 54 4A 0805 1378.00TJãã000280 54 31 39 38 35 30 37 31-35 20 20 20 20 20 20 20 T19850715 ãã000290 20 20 32 20 48 61 6E 6B-20 20 20 20 20 20 20 20 2 Hankãã 82 01-27-9417:36ALL MIKE COPELAND Spell a Number IMPORT 22 oÞb {ãFrom: MIKE COPELANDãSubj: Spell a Numberã---------------------------------------------------------------------------ã>> I'm in the process of writing a Checkbook program for my Jobã>> and I was wondering if anyone out there has a routine toã>> convert a check amount written in numerical to text. Here's anã>> example of what I need. Input Variable : 142.50ã>> Needed Output : One Hundred Forty Two 50/100--------------------ãã What you're looking for is "spell-a-number", and here's a programãwhich does it. Note that this one operates only on integer-type data,ãand you'll have to modify it for the decimal part - but that's theãeasiest task... If you have questions, just post them here.ã}ãprogram Spell_A_Number; { MRCopeland 901105 }ãUSES CRT;ãconst C_ONES : array[1..9] of string[6] = ('one ','two ','three ','four ',ã 'five ','six ','seven ','eight ','nine ');ã C_TEEN : array[0..9] of string[10] = ('ten ','eleven ','twelve ',ã 'thirteen ','fourteen ','fifteen ',ã 'sixteen ','seventeen ','eighteen',ã 'nineteen');ã C_TENS : array[2..9] of string[8] = ('twenty ','thirty ','forty ',ã 'fifty ','sixty ','seventy ','eighty ',ã 'ninety ');ãvar I,J : LongInt; { global data }ããprocedure HUNS (N : LongInt); { process a 0-999 value }ãvar P : integer; { local work variable }ãbeginã P := N div 100; N := N mod 100; { any 100-900? }ã if P > 0 thenã write (C_ONES[P],'hundred ');ã P := N div 10; N := N mod 10; { 10-90 }ã if P > 1 then { 20-90 }ã write (C_TENS[P])ã elseã if P = 1 then { 10-19 }ã write (C_TEEN[N]);ã if (P <> 1) and (N > 0) then { remainder of 1-9, 20-99 }ã write (C_ONES[N]);ãend; { HUNS }ããbegin { MAIN LINE }ã ClrScr;ã write ('Enter a value> '); readln (I);ã if I > 0 thenã beginã J := I div 1000000; I := I mod 1000000;ã if J > 0 then { process millions }ã beginã HUNS (J); write ('million ')ã end;ã J := I div 1000; I := I mod 1000;ã if J > 0 then { process thousands }ã beginã HUNS (J); write ('thousand ')ã end;ã HUNS (I) { process 0-999 remainder }ã end { if }ãend.ã 83 01-27-9417:36ALL WAYNE MOSES Checkbook Number IMPORT 45 oÀS {ãFrom: WAYNE MOSESãSubj: Spell a Numberã---------------------------------------------------------------------------ã *> Quoting Chris Serino to All on 01-04-94 17:28ã *> Re: Help Looking for a Numberãã Hello Chris:ãã CS> I'm in the process of writing a Checkbook program for my Job and Iã CS> was wondering if anyone out there has a routine to convert a checkã CS> amount written in numerical to text. Here's an example of what Iã CS> need. Input Variable : 142.50ã CS> Needed Output : One Hundred Foury Two 50/100--------------------ãã Weeeelllll ... since I am not really interested in releasing my personalã check writing program to the world, I'll upload what I wrote last month.ãã ------- 8< ------------[ CUT LINE ]-------------- >8 -------ã}ãFunction Translate(var DollarAmt : real) : string;ãã(*ã This is a module that converts the numerical dollar amount to a string,ã for example it converts $156.15 to :ãã 'One Hundred and Fifty Six dollars ------------15/xx'.ãã The field length of the translated amount is limited to 53 characters.ãã Amounts up to and including $99,999.99 are supported. I rarely writeã cheques larger than that, so they can be written by hand. ;-)ãã ======================================================================ã Dedicated to the PUBLIC DOMAIN, this software code has been tested andã used under TP 6.0/DOS and MS-DOS 6.2.ã ======================================================================ã*)ããconstã SingleSpelled : array[1..9] of string = ('One ','Two ','Three ','Four ',ã 'Five ','Six ','Seven ','Eight ',ã 'Nine ');ãã TeenSpelled : array[1..9] of string = ('Eleven ','Twelve ','Thirteen ',ã 'Fourteen ','Fifteen ','Sixteen ',ã 'Seventeen ','Eighteen ','Nineteen');ãã TenSpelled : array[1..9] of string = ('Ten ','Twenty ','Thirty ','Forty ',ã 'Fifty ','Sixty ','Seventy ','Eighty',ã 'Ninety ');ããvarã Dollars, Cents,ã SingleStr, TenStr, HundredStr, ThousandStr : string;ã Singles, Tens, Hundreds, Thousands, k, l : integer;ããbeginã if DollarAmt = 0 then (* The amount to be translated is 0.00 *)ã begin (* so the Dollars and Cents must be *)ã Dollars := 'Zero '; (* to reflect this. *)ã Cents := '00';ã endãã elseã begin (* Non trivial value for DollarAmt *)ãã SingleStr := ''; TenStr := ''; HundredStr := ''; ThousandStr := '';ãã { Parse the Cents out of DollarAmt }ãã Str(frac(DollarAmt):0:2, Cents);ã if frac(DollarAmt) > 0 thenã Cents := copy(Cents,pos('.',Cents)+1,2)ã elseã Cents := '00';ãã { Next parse the Dollars out of DollarAmt }ãã Str(int(DollarAmt):1:0, Dollars);ãã { Now, define the number of Singles, Tens, Hundreds, and Thousands }ãã Thousands := trunc(DollarAmt/1000);ãã Hundreds := trunc(DollarAmt/100)-Thousands*10;ã HundredStr := SingleSpelled[Hundreds];ãã Tens := trunc(DollarAmt/10)-(Thousands*100+Hundreds*10);ãã Singles := trunc(DollarAmt)-(Thousands*1000+Hundreds*100+Tens*10);ã SingleStr := SingleSpelled[Singles];ãã case Tens ofã 1 : beginã TenStr := TeenSpelled[Singles];ã SingleStr := '';ã end;ã 2..9 : TenStr := TenSpelled[Tens];ã end;ãã case Thousands ofã 10,20,ã 30,50,ã 60,70,ã 80,90 : ThousandStr := TenSpelled[trunc(Thousands/10)];ã 1..9 : ThousandStr := SingleSpelled[Thousands];ã 11..19 : ThousandStr := TeenSpelled[Thousands-10];ãã 21..29 : ThousandStr := TenSpelled[trunc(Thousands/10)]+ã SingleSpelled[Thousands-20];ã 31..39 : ThousandStr := TenSpelled[trunc(Thousands/10)]+ã SingleSpelled[Thousands-30];ã 41..49 : ThousandStr := TenSpelled[trunc(Thousands/10)]+ã SingleSpelled[Thousands-40];ã 51..59 : ThousandStr := TenSpelled[trunc(Thousands/10)]+ã SingleSpelled[Thousands-50];ã 61..69 : ThousandStr := TenSpelled[trunc(Thousands/10)]+ã SingleSpelled[Thousands-60];ã 71..79 : ThousandStr := TenSpelled[trunc(Thousands/10)]+ã SingleSpelled[Thousands-70];ã 81..89 : ThousandStr := TenSpelled[trunc(Thousands/10)]+ã SingleSpelled[Thousands-80];ã 91..99 : ThousandStr := TenSpelled[trunc(Thousands/10)]+ã SingleSpelled[Thousands-90];ã end;ãã if Thousands > 0 thenã Dollars := ThousandStr+'Thousand '+HundredStr+'Hundred & 'ã + TenStr + SingleStrã elseã if (Hundreds > 0) and (Thousands = 0) thenã Dollars := HundredStr+'Hundred and '+ TenStr + SingleStrã elseã Dollars := TenStr + SingleStr;ãã end; (* End of block for non-trivial *)ã (* value for DollarAmt *)ã l := length(Dollars);ãã for k := 1 to 60-(10+l+length(Cents)) doã Dollars := Dollars+'-';ãã If Thousands < 100 thenã Translate := Dollars+Cents+'/xx'ã elseã beginã TextColor(Yellow+Blink);ã Translate := '******** INVALID! THIS AMOUNT NOT SUPPORTED ********';ã end;ãend;ã 84 01-28-9408:55ALL BJORN FELTEN Simulate Phone Ringing IMPORT 10 oq {ã > I stumbled across the correct sequenceãã Well, why don't we let some more people stumble in on our little secret? :)ããSomething like this might do the trick. The brute delay code 'asm hlt end',ãthat simply waits for the next interrupt (should be the timer IRQ) to occur,ãmay not work on some machines -- especially when running some multitaskers.ãIf so it can be changed to 'delay(50)' or something like that.ã}ããprogram Ring;ãuses crt;ãvar i:word;ãbeginã for i:=0 to 6 doã beginã sound(523); asm hlt end;ã Delay(50);ã sound(659); asm hlt end;ã Delay(50);ã end;ã nosoundãend.ãã{ Or, for those of you that don't like the crt unit, here's the same thing inã BASM: }ããprogram Ring;ãbeginã asmã mov al,0B6hã out 43h,alã in al,61hã or al,3ã out 61h,alã mov cx,7ã mov dx,42hã@the_loop:ã mov al,0E9hã out dx,alã mov al,8ã out dx,alã hltã mov al,12hã out dx,alã mov al,7ã out dx,alã hltã loop @the_loopã in al,61hã and al,0FChã out 61h,alã end;ãend.ãã 85 02-03-9409:17ALL SCOTT R. HOUCK Write BANNERS IMPORT 93 o¿ Program BannerC;ãã{$V-}ãã{ Written by Scott R. Houckãã This program produces banners which can be sent to the screenã or to a file. If sent to a file, the output may be appended toã to an existing file if desired.ãã The syntax is as follows:ãã BANNER [/B=banner] [/I=infile] [/O=outfile [/A]] [/C=char]ãã whereãã banner = a character string of maximum length 10ã infile = an input file containing the banner(s)ã outfile = an output file to which the banner(s) will be writtenã char = character to be used in printing the bannerã (default = the character being printed)ãã /A = append to file if it already existsããã NOTES:ãã 1. Options may be specified in any order, but there must beã at least one space between each one. Do not put spacesã on either side of the equals sign.ãã 2. You may use PRN for the filename if you want to send theã output to the printer. If you choose to do this, do notã use the /A option.ãã 3. To indicate a space in the banner when using the /B option, useã the carat symbol (^). Example: BANNER /O=DISKFILE /B=JOHN^DOEã However, this is not necessary if you are using the /I option.ãã 4. Valid characters are 0-9, A-Z, and !"#$%&'()*+,-./:;<=>?@[\]ã Any other characters will be printed as a space.ãã 6. All lower case letters are converted to upper case.ãã 7. Three blank lines are written before the banner is output.ãã 8. Note that /B and /I are mutually exclusive and will produce aã syntax error if used together.ãã 9. If all options are omitted or if the command line does not containã either /B or /I, the command syntax is printed.ãã 10. /A will produce a syntax error if used without /O.ãã 11. You may not use < or > with the /B option because DOS wouldã interpret it as redirection of standard input and output.ãã}ããUSES DOS,CRT;ããTypeã str13 = string[13];ã str80 = string[80];ã char_pattern = array[1..10] of integer;ããConstã bit_value: array[1..10] of integer = (1,2,4,8,16,32,64,128,256,512);ãã char_def: array[#32..#94] of char_pattern = (ãã {32:' '} ($000,$000,$000,$000,$000,$000,$000,$000,$000,$000),ã {33:'!'} ($030,$078,$0FC,$0FC,$078,$078,$030,$000,$030,$030),ã {34:'"'} ($1CE,$1CE,$1CE,$1CE,$000,$000,$000,$000,$000,$000), ã {35:'#'} ($0CC,$0CC,$0CC,$3FF,$0CC,$0CC,$3FF,$0CC,$0CC,$0CC), ã {36:'$'} ($030,$1FE,$3FF,$330,$3FF,$1FF,$033,$3FF,$1FE,$030),ã {37:'%'} ($1C3,$366,$36C,$1D8,$030,$060,$0CE,$19B,$31B,$20E),ã {38:'&'} ($1E0,$330,$330,$1C0,$1E0,$331,$31A,$31C,$1FA,$0E1), ã {39:'''} ($070,$0F8,$078,$010,$020,$000,$000,$000,$000,$000),ã {40:'('} ($004,$018,$030,$060,$060,$060,$060,$030,$018,$004),ã {41:')'} ($080,$060,$030,$018,$018,$018,$018,$030,$060,$080),ã {42:'*'} ($000,$000,$000,$084,$048,$2FD,$048,$084,$000,$000),ã {43:'+'} ($000,$000,$078,$078,$3FF,$3FF,$078,$078,$000,$000),ã {44:','} ($000,$000,$000,$000,$000,$070,$0F8,$078,$010,$020),ã {45:'-'} ($000,$000,$000,$000,$3FF,$3FF,$000,$000,$000,$000), ã {46:'.'} ($000,$000,$000,$000,$000,$000,$000,$078,$0FC,$078),ã {47:'/'} ($001,$003,$006,$00C,$018,$030,$060,$0C0,$180,$100),ã {48:'0'} ($078,$0FC,$186,$303,$303,$303,$303,$186,$0FC,$078),ã {49:'1'} ($030,$0F0,$0B0,$030,$030,$030,$030,$030,$3FF,$3FF),ã {50:'2'} ($1FE,$3FF,$203,$003,$003,$018,$060,$0C0,$3FF,$3FF),ã {51:'3'} ($3FF,$3FE,$00C,$018,$038,$00E,$006,$203,$3FF,$1FE),ã {52:'4'} ($01C,$03C,$06C,$0CC,$18C,$3FF,$3FF,$00C,$00C,$00C),ã {53:'5'} ($3FF,$3FF,$300,$300,$3FE,$3FF,$003,$203,$3FF,$1FE),ã {54:'6'} ($1FE,$3FF,$301,$300,$3FE,$3FF,$303,$303,$3FF,$1FE),ã {55:'7'} ($3FF,$3FF,$006,$00C,$018,$030,$060,$0C0,$300,$300),ã {56:'8'} ($1FE,$3FF,$303,$303,$1FE,$1FE,$303,$303,$3FF,$1FE),ã {57:'9'} ($1FE,$3FF,$303,$303,$3FF,$1FF,$003,$003,$3FF,$1FE),ã {58:':'} ($000,$000,$000,$078,$0FC,$078,$000,$078,$0FC,$078),ã {59:';'} ($000,$038,$07C,$038,$000,$038,$07C,$03C,$004,$008),ã {60:'<'} ($000,$000,$003,$00C,$030,$0C0,$030,$00C,$003,$000),ã {61:'='} ($000,$000,$000,$3FF,$3FF,$000,$3FF,$3FF,$000,$000),ã {62:'>'} ($000,$000,$0C0,$030,$00C,$003,$00C,$030,$0C0,$000),ã {63:'?'} ($1FE,$3FF,$303,$006,$00C,$018,$018,$000,$018,$018), ã {64:'@'} ($1FE,$303,$33B,$36B,$363,$363,$366,$37C,$300,$1FE), ã {65:'A'} ($1FE,$3FF,$303,$303,$303,$3FF,$3FF,$303,$303,$303),ã {66:'B'} ($3FE,$3FF,$303,$303,$3FE,$3FE,$303,$303,$3FF,$3FE),ã {67:'C'} ($1FE,$3FF,$301,$300,$300,$300,$300,$301,$3FF,$1FE),ã {68:'D'} ($3FE,$3FF,$303,$303,$303,$303,$303,$303,$3FF,$3FE),ã {69:'E'} ($3FF,$3FF,$300,$300,$3E0,$3E0,$300,$300,$3FF,$3FF),ã {70:'F'} ($3FF,$3FF,$300,$300,$3E0,$3E0,$300,$300,$300,$300),ã {71:'G'} ($1FE,$3FF,$300,$300,$31F,$31F,$303,$303,$3FF,$1FF),ã {72:'H'} ($303,$303,$303,$303,$3FF,$3FF,$303,$303,$303,$303),ã {73:'I'} ($3FF,$3FF,$030,$030,$030,$030,$030,$030,$3FF,$3FF),ã {74:'J'} ($0FF,$0FF,$018,$018,$018,$018,$318,$318,$3F8,$1F0),ã {75:'K'} ($303,$306,$318,$360,$3E0,$330,$318,$30C,$306,$303),ã {76:'L'} ($300,$300,$300,$300,$300,$300,$300,$300,$3FF,$3FF),ã {77:'M'} ($303,$3CF,$37B,$333,$333,$303,$303,$303,$303,$303),ã {78:'N'} ($303,$383,$343,$363,$333,$333,$31B,$30B,$307,$303),ã {79:'O'} ($1FE,$3FF,$303,$303,$303,$303,$303,$303,$3FF,$1FE),ã {80:'P'} ($3FE,$3FF,$303,$303,$3FF,$3FE,$300,$300,$300,$300),ã {81:'Q'} ($1FE,$3FF,$303,$303,$303,$303,$33B,$30F,$3FE,$1FB),ã {82:'R'} ($3FE,$3FF,$303,$303,$3FF,$3FE,$318,$30C,$306,$303),ã {83:'S'} ($1FE,$3FF,$301,$300,$3FE,$1FF,$003,$203,$3FF,$1FE),ã {84:'T'} ($3FF,$3FF,$030,$030,$030,$030,$030,$030,$030,$030),ã {85:'U'} ($303,$303,$303,$303,$303,$303,$303,$303,$3FF,$1FE),ã {86:'V'} ($303,$303,$186,$186,$186,$186,$0CC,$0CC,$078,$030),ã {87:'W'} ($303,$303,$303,$303,$333,$333,$333,$37B,$1CE,$186),ã {88:'X'} ($303,$186,$0CC,$078,$030,$078,$0CC,$186,$303,$303),ã {89:'Y'} ($303,$186,$0CC,$078,$030,$030,$030,$030,$030,$030),ã {90:'Z'} ($3FF,$3FE,$00C,$018,$030,$030,$060,$0C0,$1FF,$3FF),ã {91:'['} ($0FE,$0FE,$0C0,$0C0,$0C0,$0C0,$0C0,$0C0,$0FE,$0FE),ã {92:'\'} ($200,$300,$180,$0C0,$060,$030,$018,$00C,$006,$002),ã {93:']'} ($0FE,$0FE,$006,$006,$006,$006,$006,$006,$0FE,$0FE),ã {94:'^'} ($000,$000,$000,$000,$000,$000,$000,$000,$000,$000) );ããVarã character: char;ã banner: str13;ã Param: array[1..4] of str80;ã InfileName, OutfileName: str80;ã Infile, Outfile: text;ã Slash_A, Slash_B, Slash_C, Slash_I, Slash_O: boolean;ãã{----------------------------------------------------------------------}ããProcedure Beep;ããbeginã Sound(350);ã Delay(300);ã NoSound;ãend;ãã{----------------------------------------------------------------------}ããProcedure UpperCase(var AnyStr: str80);ããvarã i: integer;ããbeginã For i := 1 to length(AnyStr) do AnyStr[i] := UpCase(AnyStr[i]);ãend;ãã{----------------------------------------------------------------------}ããFunction Exist(filename: str80): boolean;ããvarã tempfile: file;ããbeginã Assign(tempfile,filename);ã {$I-}ã Reset(tempfile);ã {$I+}ã Exist := (IOresult = 0);ã Close(tempfile);ãend;ãã{----------------------------------------------------------------------}ããProcedure Print_Syntax;ããbeginã Writeln('The syntax is as follows:'^J);ã Writeln(' BANNER [/B=banner] [/I=infile] [/O=outfile [/A]] ',ã '[/C=char]'^J);ã Writeln('where'^J);ã Writeln(' banner = character string of maximum length 10');ã Writeln(' infile = input file containing banner text');ã Writeln(' outfile = output file to which the banner(s) will be ',ã 'written');ã Writeln(' char = character to be used in printing the banner');ã Writeln(' (default = the character being printed)'^J);ã Writeln(' /A = append to file if it already exists'^J);ã Writeln('Note that /B and /I are mutually exclusive.');ã Writeln('Use a carat (^) for a space if using /B.');ã Writeln('Valid characters are 0-9, A-Z, and ',ã '!"#$%&''()*+,-./:;<=>?@[\]');ãend;ãã{----------------------------------------------------------------------}ããProcedure Parse;ããvarã n, b, c, i, o: integer;ã ch1, ch2, ch3: char;ãã {*} procedure Error;ã beginã Beep;ã Print_Syntax;ã Halt;ã end;ããbegin { Parse }ãã Slash_A := false;ã Slash_B := false; b := 0;ã Slash_C := false; c := 0;ã Slash_I := false; i := 0;ã Slash_O := false; o := 0;ãã If ParamCount = 0 thenã beginã Print_Syntax;ã Halt;ã end;ãã If ParamCount > 4 then Error;ãã For n := 1 to ParamCount doã beginã Param[n] := ParamStr(n);ã UpperCase(Param[n]);ã ch1 := Param[n][1];ã ch2 := Param[n][2];ã ch3 := Param[n][3];ã If (ch1 <> '/') or not (ch2 in ['A','B','C','I','O']) then Error;ã If ch2 = 'A' thenã Slash_A := true;ã If ch2 = 'B' thenã beginã Slash_B := true;ã b := n;ã end;ã If ch2 = 'C' thenã beginã Slash_C := true;ã c := n;ã end;ã If ch2 = 'I' thenã beginã Slash_I := true;ã i := n;ã end;ã If ch2 = 'O' thenã beginã Slash_O := true;ã o := n;ã end;ã If (ch2 in ['B','C','I','O']) and (ch3 <> '=') then Error;ã If (ch2 = 'A') and (length(ch2) > 2) then Error;ã end;ãã If Slash_B and Slash_I then Error;ã If not Slash_B and not Slash_I then Error;ã If Slash_A and not Slash_O then Error;ã If Slash_B thenã beginã banner := Param[b];ã Delete(banner,1,3);ã end;ã If Slash_C then character := Param[c][4];ã If Slash_I thenã beginã InfileName := Param[i];ã Delete(InfileName,1,3);ã end;ã If Slash_O thenã beginã OutfileName := Param[o];ã Delete(OutfileName,1,3);ã end;ããend;ãã{----------------------------------------------------------------------}ããProcedure Heading(message: str13);ããvarã i, j, k: integer;ããbeginãã If Slash_Oã then Writeln(Outfile,^M^J^M^J^M^J)ã else Writeln(^J^J^J);ãã For i := 1 to 10 doã beginã For j := 1 to length(message) doã beginã If not (message[j] in [#32..#94]) then message[j] := #32;ã For k := 10 downto 1 doã If char_def[message[j],i] and bit_value[k] = bit_value[k]ã thenã beginã If not Slash_C then character := message[j];ã If Slash_Oã then Write(Outfile,character)ã else Write(character);ã endã elseã beginã If Slash_Oã then Write(Outfile,' ')ã else Write(' ');ã end;ã If Slash_Oã then Write(Outfile,' ')ã else Write(' ');ã end;ã If Slash_Oã then Writeln(Outfile)ã else Writeln;ã end;ããend;ãã{----------------------------------------------------------------------}ããBegin { Banner }ãã Parse;ãã If Slash_O thenã beginã Assign(Outfile,OutfileName);ã If Slash_A and Exist(OutfileName)ã then Append(Outfile)ã else Rewrite(Outfile);ã end;ãã If Slash_I thenã beginã Assign(Infile,InfileName);ã Reset(Infile);ã While not Eof(Infile) doã beginã Readln(Infile,banner);ã UpperCase(banner);ã Heading(banner);ã end;ã Close(Infile);ã endãã else Heading(banner);ãã If Slash_O then Close(Outfile);ããEnd.ã 86 02-03-9409:59ALL SWAG SUPPORT TEAM Accessing DBASE3 Files IMPORT 52 o¡¦ unit dbaseiii;ã{ unit including procedures for accessing DBaseIII files}ããinterfaceããuses Crt;ããProcedure OpenDBFData;ãProcedure OpenDBFMemo;ãProcedure ReadDBFRecord(I : Longint);ãProcedure WriteDBFRecord;ãProcedure ReadDBFMemo(BlockNumber : integer);ãProcedure WriteDBFMemo(var BlockNumberString : string);ãProcedure CloseDBFData;ãProcedure CloseDBFMemo;ããconstã DBFMaxRecordLength = 4096;ã DBFMemoBlockLength = 512;ã DBFMaxMemoLength = 4096;ããtypeã DBFHeaderRec = Recordã HeadType : byte;ã Year : byte;ã Month : byte;ã Day : byte;ã RecordCount : longint;ã HeaderLength : integer;ã RecordSize : integer;ã Garbage : array[1..20] of byte;ã end;ããtypeã DBFFieldRec = Recordã FieldName : array[1..11] of char;ã FieldType : char;ã Spare1,ã Spare2 : integer;ã Width : byte;ã Dec : byte;ã WorkSpace : array[1..14] of byte;ã end;ããvarã DBFFileName : string;ãã DBFDataFile : File;ã DBFDataFileAvailable : boolean;ã DBFBuffer : array [1..DBFMaxRecordLength] of char;ãã DBFHeading : DBFHeaderRec;ãã DBFField : DBFFieldRec;ã DBFFieldCount : integer;ã DBFFieldContent : array [1..128] of string;ãã DBFNames : array [1..128] of string[10];ã DBFLengths : array [1..128] of byte;ã DBFTypes : array [1..128] of char;ã DBFDecimals : array [1..128] of byte;ã DBFContentStart : array [1..128] of integer;ãã DBFMemoFile : File;ã DBFMemoFileAvailable : boolean;ã DBFMemoBuffer : Array [1..DBFMemoBlockLength] of byte;ã DBFMemo : Array [1..DBFMaxMemoLength] of char;ãã DBFMemoLength : integer;ã DBFMemoEnd : boolean;ã DBFMemoBlock : integer;ãã DBFDeleteField : char;ã DBFFieldStart : integer;ãã DBFRecordNumber : longint;ãã(****************************************************************)ããimplementationãã(****************************************************************)ããProcedure ReadDBFHeader;ããvarã RecordsRead : integer;ããbeginã BlockRead (DBFDataFile, DBFHeading, SizeOf(DBFHeading), RecordsRead);ãend;ãã(*****************************************************************)ããProcedure ProcessField (F : DBFFieldRec;ã I : integer);ãvarã J : integer;ããbeginã with F doã beginã DBFNames [I] := '';ã J := 1;ã while (J<11) and (FieldName[J] <> #0) doã beginã DBFNames[I] := DBFNames[I] + FieldName [J];ã J := J + 1;ã end;ã DBFLengths [I] := Width;ã DBFTypes [I] := FieldType;ã DBFDecimals [I] := Dec;ã DBFContentStart [I] := DBFFieldStart;ã DBFFieldStart := DBFFieldStart + Width;ã end;ãend;ãã(***************************************************************)ããProcedure ReadFields;ããvarã I : integer;ã RecordsRead : integer;ããbeginã Seek(DBFDataFile,32);ã I := 1;ã DBFFieldStart := 2;ã DBFField.FieldName[1] := ' ';ã while (DBFField.FieldName[1] <> #13) doã beginã BlockRead(DBFDataFile,DBFField.FieldName[1],1);ã if (DBFField.FieldName[1] <> #13) thenã beginã BlockRead(DBFDataFile, DBFField.FieldName[2],SizeOf(DBFField) - 1, RecordsRead);ã ProcessField (DBFField, I);ã I := I + 1;ã end;ã end;ã DBFFieldCount := I - 1;ãend;ãã(***********************************************************)ããProcedure OpenDBFData;ããbeginã DBFDataFileAvailable := false;ã Assign(DBFDataFile, DBFFileName+'.DBF');ãã{$I-}ã Reset(DBFDataFile,1);ã If IOResult<>0 then exit;ã{$I+}ãã DBFDataFileAvailable := true;ã Seek(DBFDataFile,0);ã ReadDBFHeader;ã ReadFields;ãend;ãã(******************************************************************)ããProcedure CloseDBFData;ããbeginã if DBFDataFileAvailable then Close(DBFDataFile);ãend;ãã(*******************************************************************)ããProcedure OpenDBFMemo;ããbeginã DBFMemoFileAvailable := false;ã Assign(DBFMemoFile, DBFFileName+'.DBT');ãã{$I-}ã Reset(DBFMemoFile,1);ã If IOResult<>0 then exit;ã{$I+}ãã DBFMemoFileAvailable := true;ã Seek(DBFMemoFile,0);ãend;ãã(*******************************************************************)ããProcedure CloseDBFMemo;ããbeginã If DBFMemoFileAvailable then close(DBFMemoFile);ãend;ãã(*******************************************************************)ããProcedure GetDBFFields;ããvarã I : byte;ã J : integer;ã Response : string;ããbeginã DBFDeleteField := DBFBuffer[1];ã For I:=1 to DBFFieldCount doã beginã DBFFieldContent[I] := '';ã For J := DBFContentStart[I] to DBFContentStart [I] + DBFLengths[I] -1 doã DBFFieldContent[I] := DBFFieldContent[I] + DBFBuffer[J];ã For J := 1 to DBFLengths[I] doã if DBFFieldContent[J]=#0 then DBFFieldContent[J]:=#32;ã end;ãend;ãã(***********************************************************************)ããProcedure ReadDBFRecord (I : Longint);ããvarã RecordsRead : integer;ããbeginã Seek(DBFDataFile, DBFHeading.HeaderLength + DBFHeading.RecordSize * (I - 1));ã BlockRead (DBFDataFile, DBFBuffer, DBFHeading.RecordSize, RecordsRead);ã GetDBFFields;ãend;ãã(**********************************************************************)ããProcedure ReadDBFMemo(BlockNumber : integer);ããvarã I : integer;ã RecordsRead : word;ããbeginã DBFMemoLength := 0;ã DBFMemoEnd := false;ã If not DBFMemoFileAvailable thenã beginã DBFMemoEnd := true;ã exit;ã end;ã FillChar(DBFMemo[1],DBFMaxMemoLength,#0);ã Seek(DBFMemoFile,BlockNumber*DBFMemoBlockLength);ã repeatã BlockRead(DBFMemoFile,DBFMemoBuffer,DBFMemoBlockLength,RecordsRead);ã For I := 1 to RecordsRead doã beginã DBFMemoLength := DBFMemoLength + 1;ã DBFMemo[DBFMemoLength] := chr(DBFMemoBuffer[I] and $7F);ã If (DBFMemoBuffer[I] = $1A) or (DBFMemoBuffer[I] = $00) thenã beginã DBFMemoEnd := true;ã DBFMemoLength := DBFMemoLength - 1;ã exit;ã end;ã end;ã until DBFMemoEnd;ãend;ãã(*********************************************************************)ããProcedure WriteDBFMemo {(var BlockNumberString : string)};ããvarã K : integer;ã ReturnCode : integer;ããbeginã Val(BlockNumberString,DBFMemoBlock,ReturnCode);ã If ReturnCode>0 then DBFMemoBlock := 0;ã If DBFMemoBlock>0 thenã beginã Writeln;ã ReadDBFMemo(DBFMemoBlock);ã If DBFMemoLength=0 then exit;ã For K := 1 to DBFMemoLength doã Write(DBFMemo[K]);ã WriteLn;ã end;ãend;ãã(****************************************************************)ããProcedure WriteDBFRecord;ããvarã J : byte;ããbeginã For J := 1 to DBFFieldCount doã beginã Write(DBFNames[J]);ã GoToXY(12,J);ã WriteLn(DBFFieldContent[J]);ã if DBFTypes[J]='M' then WriteDBFMemo(DBFFieldContent[J]);ã end;ãend;ãã(*******************************************************************)ããbeginãend.ã 87 02-03-9410:57ALL WIM VAN DER VEGT Fuzzy logic unit (German)IMPORT 151 o? {ã---------------------------------------------------------------------------ãKW>WV>Got some german pascal code on this subject. It seems to implement aã > >.... (Bit large to send if nobody's interested).ããKW>Can you extract the specifically fuzzy logic parts?ã >---ãNo (didnt know where to look, how doesfuzzy pascal look 🙂 ) so here'sãthe complete program taken from a german magazineã}ããUNIT Fuzzy;ãINTERFACEããUses Graph,Crt,Dos;ããCONSTã Infinity = 1.7e38;ã NoRules = NIL;ã ValueCol = LightMagenta;ããTYPEã NameStr = String[20];ã (* verschiedene Operatortypen *)ã Inference = FUNCTION(Set1,Set2,Set3:Real):real;ãã FuzzySetList = ^FuzzySet;ã FuzzyVarList = ^FuzzyVar;ã FuzzyRuleList = ^FuzzyRule;ãã FuzzySet = Objectã SetName : NameStr; (* Mengenbenzeichner *)ã StartAt, (* Startwert *)ã HighAt, (* Maximum bei ... *)ã EndAt : Real; (* Endwert *)ã Next : FuzzySetList;ã Color : Byte;ã MemberShip : Real; (* aktueller Wert der *)ã (* Zugehrigkeit *)ã Rules : FuzzyRuleList; (* Regelliste fr diese *)ã (* unscharfe Menge *)ã Constructor Init( InitName : NameStr;ã InitStart, InitHigh,ã InitEnd : Real;ã InitColor: Byte);ã PROCEDURE Append( InitName : NameStr;ã InitStart, InitHigh,ã InitEnd : Real;ã InitColor: Byte);ã FUNCTION GetMemberShip(LingVal : Real):Real;ã PROCEDURE DefineRule( InfType : Inference;ã Var1 : FuzzyVarList;ã SetName1: NameStr;ã Var2 : FuzzyVarList;ã SetName2: NameStr);ã END;ãã FuzzyVar = Objectã VarName : NameStr; (* Variablenname *)ã PosX,PosY : WORD; (* Bildschirmkoordinaten*)ã StartValue, (* Anfang und Ende des *)ã EndValue, (* Koordinatensystems *)ã Scale : Real; (* Maástabsfaktor *)ã UnitStr : NameStr; (* Einheit, z.B. øC *)ã CurrentVal: Real; (* aktueller Wert *)ã FuzzySets : FuzzySetList; (* Liste der unscharfen *)ã (* Mengen *)ã Result,BackGround :ã ARRAY[1..5] OF PointType;ã Constructor Init( InitName : NameStr;ã InitX,InitY : WORD;ã Sections : Byte;ã InitStart,InitEnd,ã InitValue : Real;ã InitUnit : NameStr);ã PROCEDURE CoordSystem(Sections : Byte);ã FUNCTION RealToCoord(r:Real):WORD;ã PROCEDURE DisplaySets;ã PROCEDURE DisplayValue(TextColor:WORD);ã PROCEDURE DisplayResultSets;ã PROCEDURE Change(Diff : Real);ã FUNCTION GetMemberShipOf(Name : NameStr):Real;ã PROCEDURE Infer;ã PROCEDURE DeFuzzy;ã PROCEDURE DefineSet( InitName : NameStr;ã InitStart, InitHigh,ã InitEnd : Real;ã InitColor: Byte);ã PROCEDURE DefineRule(SetName : NameStr;ã InfType : Inference;ã Var1 : FuzzyVarList;ã SetName1 : NameStr;ã Var2 : FuzzyVarList;ã SetName2 : NameStr);ã END;ãã FuzzyRule = Objectã Inf_Type : Inference; (* Operatortyp *)ã Var1, Var2 : FuzzyVarList; (* Eingangsvariablen *)ã SetName1, SetName2 : NameStr; (* Eingangsmengen *)ã Next : FuzzyRuleList;ã Constructor Init( InitInf : Inference;ã InitVar1 : FuzzyVarList;ã InitName1 : NameStr;ã InitVar2 : FuzzyVarList;ã InitName2 : NameStr);ã PROCEDURE Append( InitInf : Inference;ã InitVar1 : FuzzyVarList;ã InitName1 : NameStr;ã InitVar2 : FuzzyVarList;ã InitName2 : NameStr);ã FUNCTION Infer(HomeSetValue:Real):Real;ã END;ããProcedure Buzz;ãprocedure error(message : string);ããfunction Max( A, B: Real ): Real;ãfunction Min( A, B: Real ): Real;ããFUNCTION AND_MaxMin(Set1,Set2,Set3:Real):Real;ãFUNCTION OR_MaxMax(Set1,Set2,Set3:Real):Real;ããVARã DisplayOn : BOOLEAN; (* Anzeige der unscharfen Mengen ein/aus *)ã Regs : Registers;ã ResultCol : WORD;ããImplementationããCONST OffSet = 20;ããVAR Buffer : String;ããPROCEDURE Buzz;ãBEGIN sound(30); Delay(100); NoSound; END;ããprocedure error(message : string);ãbeginã CloseGraph; writeln(message); haltãend;ããfunction Max( A, B: Real ): Real;ãbeginã if A < B then Max := B else Max := A;ãend;ããfunction Min( A, B: Real ): Real;ãbeginã if A > B then Min := B else Min := A;ãend;ãã(* MaxMin-Operator fr UND *)ãFUNCTION AND_MaxMin(Set1,Set2,Set3:Real):Real;ãBEGINã AND_MaxMin:=Max(Set1,Min(Set2,Set3))ãEND;ãã(* MaxMax-Operator fr ODER *)ãFUNCTION OR_MaxMax(Set1,Set2,Set3:Real):Real;ãBEGINã OR_MaxMax:=Max(Set1,Max(Set2,Set3))ãEND;ããCONSTRUCTOR FuzzySet.Init;ããBEGINã SetName := InitName;ã StartAt := InitStart;ã HighAt := InitHigh;ã EndAt := InitEnd;ã Color := InitColor;ã Next := NIL;ã Rules:= NoRules;ã MemberShip := 0;ãEND;ããPROCEDURE FuzzySet.Append;ãBEGINã IF Next=NILã THEN New(Next,Init(InitName,InitStart,InitHigh,InitEnd,InitColor))ã ELSE Next^.Append(InitName,InitStart,InitHigh,InitEnd,InitColor)ãEND;ããFUNCTION FuzzySet.GetMemberShip;ãBEGINã IF (LingVal<=StartAt) THEN GetMemberShip:=0ã ELSE IF (LingVal>=EndAt) THEN GetMemberShip:=0ã ELSEã BEGINã IF ((StartAt=-Infinity) AND (LingVal<=HighAt))ã OR ((EndAt=Infinity) AND (LingVal>=HighAt)) THEN GetMemberShip:=1ã ELSE IF (LingVal<=HighAt)ã THEN GetMemberShip:=(LingVal-StartAt)/(HighAt-StartAt)ã ELSE GetMemberShip:=1-(LingVal-HighAt)/(EndAt-HighAt)ã ENDãEND;ããPROCEDURE FuzzySet.DefineRule;ãBEGINã IF Rules=NoRules THENã Rules:= new(FuzzyRuleList,ã Init(InfType,Var1,SetName1,Var2,SetName2))ã ELSE Rules^.Append(InfType,Var1,SetName1,Var2,SetName2)ãEND;ããCONSTRUCTOR FuzzyVar.Init;ãBEGINã VarName:=InitName;ã PosX:=InitX;ã PosY:=InitY;ã StartValue:=InitStart;ã EndValue :=InitEnd;ã Scale :=210/(EndValue-StartValue);ã UnitStr :=InitUnit;ã CurrentVal:=InitValue;ã CoordSystem(Sections);ã FuzzySets :=NIL;ã BackGround[1].x:=PosX+1; BackGround[1].y:=PosY+100;ã BackGround[2].x:=PosX+1; BackGround[2].y:=PosY+20;ã BackGround[3].x:=PosX+250; BackGround[3].y:=PosY+20;ã BackGround[4].x:=PosX+250; BackGround[4].y:=PosY+100;ã BackGround[5]:=BackGround[1];ãEND;ããFUNCTION FuzzyVar.RealToCoord(r:Real):WORD;ãBEGINã RealToCoord:=PosX+OffSet+Round((r-StartValue)*Scale);ãEND;ããPROCEDURE FuzzyVar.CoordSystem(Sections: BYTE);ã(* zeichnet ein Koordinatensystem *)ã(* PosX, PosY bestimmen die linke obere Ecke *)ãVAR N : Byte;ã MarkerX : WORD;ã Increment : Real;ãBEGINã SetColor(White);ã SetTextJustify(CenterText,CenterText);ã Line( PosX, PosY, PosX, PosY+103 );ã Line( PosX-3, PosY+100, PosX+250, PosY+100 );ã Line( PosX, PosY+20, PosX-3, PosY+20 );ã OutTextXY( PosX-15, PosY+20, '1' );ã OutTextXY( PosX-15, PosY+100, '0' );ã Increment :=(EndValue-StartValue)/(Sections-1);ã for N := 0 to Sections-1 doã beginã MarkerX:=RealToCoord(StartValue+N*Increment);ã Line(MarkerX,PosY+101,MarkerX,PosY+103);ã Str(Round(StartValue + N * Increment), Buffer );ã OutTextXY(MarkerX, PosY+113, Buffer );ã end;ã OutTextXY( PosX + 270, PosY + 113, '['+UnitStr+']');ã SetColor(Red);ã SetTextJustify(LeftText,CenterText);ã OutTextXY( PosX + 20, PosY + 140,VarName+' = ');ã OutTextXY( PosX + 200,PosY + 140,UnitStr);ãEND;ããPROCEDURE FuzzyVar.DisplayValue;ããBEGINã SetWriteMode(XORPut);ã SetColor(ValueCol);ã IF (CurrentVal>=StartValue) AND (CurrentVal<=EndValue)ã THEN Line(RealToCoord(CurrentVal),PosY+20,ã RealToCoord(CurrentVal),PosY+100);ã SetColor(TextColor);ã SetTextJustify(RightText,CenterText);ã Str(CurrentVal : 7 : 2, Buffer );ã OutTextXY( PosX+190, PosY + 140 , Buffer );ãEND;ããPROCEDURE FuzzyVar.Change;ãBEGINã IF (CurrentVal+Diff>=StartValue) AND (CurrentVal+Diff<=EndValue)ã THENã BEGINã DisplayValue(0);ã CurrentVal:=CurrentVal+Diff;ã DisplayValue(ValueCol);ã ENDã ELSE (* Bereichsgrenzen berschritten *)ã Buzz;ãEND;ããPROCEDURE FuzzyVar.DisplaySets;ã(* zeigt die unscharfen Mengen einer Variablen an *)ãVAR SetPtr : FuzzySetList;ãBEGINã SetPtr:=FuzzySets;ã WHILE SetPtr<>NIL DO WITH SetPtr^ DOã BEGINã SetColor(Color);ã IF StartAt=-Infinity THEN SetTextJustify(RightText,CenterText)ã ELSE IF EndAt=Infinity THEN SetTextJustify(LeftText,CenterText)ã ELSE SetTextJustify(CenterText,CenterText);ã OutTextXY(RealToCoord(HighAt),PosY+10,SetName);ã IF StartAt=-Infinityã THEN Line(PosX,PosY+20,RealToCoord(HighAt),PosY+20)ã ELSE Line( RealToCoord(StartAt),PosY+100,ã RealToCoord(HighAt),PosY+20);ã IF EndAt=Infinityã THEN Line(RealToCoord(HighAt),PosY+20,PosX+250,PosY+20)ã ELSE Line(RealToCoord(HighAt),PosY+20,RealToCoord(EndAt),PosY+100);ã SetPtr:=Nextã ENDãEND;ããFUNCTION FuzzyVar.GetMemberShipOf;ãVAR SetPtr : FuzzySetList;ãBEGINã SetPtr:=FuzzySets;ã WHILE (SetPtr<>NIL) AND (SetPtr^.SetName<>Name) DO SetPtr:=SetPtr^.Next;ã IF SetPtr=NIL THEN error( 'Menge '+Name+' ist in der Ling. Variablen 'ã +VarName+' nicht definiert!')ã ELSE GetMemberShipOf:=SetPtr^.GetMemberShip(CurrentVal)ãEND;ããPROCEDURE FuzzyVar.DisplayResultSets;ãVAR SetPtr : FuzzySetList;ãBEGINã SetWriteMode(CopyPut);ã SetColor(ResultCol);ã SetPtr:=FuzzySets;ã WHILE SetPtr<>NIL DO WITH SetPtr^ DOã BEGINã IF MemberShip>0 THENã BEGINã IF StartAt<=StartValue THEN Result[1].x := RealToCoord(StartValue)ã ELSE Result[1].x := RealToCoord(StartAt);ã Result[1].y := PosY+99;ã Result[2].x := RealToCoord(HighAt);ã Result[2].y := PosY+99 - Round(MemberShip*79);ã IF EndAt>=EndValue THEN Result[3].x := RealToCoord(EndValue)ã ELSE Result[3].x:= RealToCoord(EndAt);ã Result[3].y := PosY+99;ã Result[4] := Result[1];ã FillPoly( 4, Result )ã END;ã SetPtr:=nextã ENDãEND;ããPROCEDURE FuzzyVar.Infer; (* alle Regeln antriggern *)ãVARã SetPtr : FuzzySetList;ã RulePtr: FuzzyRuleList;ãBEGINã SetPtr:=FuzzySets;ã WHILE SetPtr<>NIL DO WITH SetPtr^ DOã BEGINã RulePtr:=Rules;ã MemberShip:=0;ã WHILE RulePtr<>NIL DOã BEGINã MemberShip:=RulePtr^.Infer(MemberShip);ã RulePtr:=RulePtr^.Nextã END;ã SetPtr:=Nextã ENDãEND; (* FuzzyVar.Infer *)ããPROCEDURE FuzzyVar.Defuzzy;ã(* Bestimmung des Flchenschwerpunktes der unscharfen *)ã(* Ergebnismenge durch Auszhlen der Pixel *)ãã(* Raster der Rechnergeschwindigkeit anpassen *)ã(* gráte Rechengenauigkeit bei Raster=1 *)ãCONST Raster = 16;ãVARã X,Y,XOffSet : WORD;ã Zaehler, Nenner: Real;ãBEGINã DisplayValue(Black);ã SetFillStyle(SolidFill, Black);ã SetColor(Black);ã FillPoly(5, BackGround);ã SetFillStyle(SolidFill, ResultCol);ã IF DisplayOnã THEN DisplaySets; (* verzerrt das Ergebnis auf Hercules *)ã DisplayResultSets;ã Zaehler :=0;ã Nenner :=0;ã XOffset :=PosX+20;ã for X := 0 TO 210 DIV Raster DO (* Flchenschwerpunkt bestimmen *)ã for Y := PosY + 20 to PosY + 100 doã if GetPixel(Raster*X+XOffSet,Y) = ResultCol thenã beginã Nenner:=Nenner+1;ã Zaehler:=Zaehler+Raster*X;ã end;ã IF Nenner=0 THEN CurrentVal:=0ã ELSE CurrentVal :=Zaehler/Nenner/Scale+StartValue;ã DisplayValue(ResultCol)ãend;ããPROCEDURE FuzzyVar.DefineRule;ãVAR SetPtr : FuzzySetList;ãBEGINã SetPtr:=FuzzySets;ã WHILE (SetPtr<>NIL) AND (SetPtr^.SetName<>SetName)ã DO SetPtr:=SetPtr^.Next;ã IF SetPtr=NIL THEN error( 'Menge '+SetName+' ist in der Ling. '+ã 'Variablen '+VarName+' nicht definiert!')ã ELSE SetPtr^.DefineRule(InfType,Var1,SetName1,Var2,SetName2)ãEND;ããPROCEDURE FuzzyVar.DefineSet;ãBEGINã IF FuzzySets = NILã THEN FuzzySets:= new(FuzzySetList,ã Init(InitName,InitStart,InitHigh,InitEnd,InitColor))ã ELSE FuzzySets^.Append(InitName,InitStart,InitHigh,InitEnd,InitColor)ãEND;ããCONSTRUCTOR FuzzyRule.Init;ãBEGINã Inf_Type :=InitInf;ã Var1 :=InitVar1;ã Var2 :=InitVar2;ã SetName1 :=InitName1;ã SetName2 :=InitName2;ã Next :=NILãEND;ããPROCEDURE FuzzyRule.Append;ãBEGINã IF Next=NILã THEN New(Next,Init(InitInf,InitVar1,InitName1,InitVar1,InitName2))ã ELSE Next^.Append(InitInf,InitVar1,InitName1,InitVar2,InitName2)ãEND;ããFUNCTION FuzzyRule.Infer; (* einzelne Regel abarbeiten *)ãBEGINã Infer:=Inf_Type(HomeSetValue, Var1^.GetMemberShipOf(SetName1),ã Var2^.GetMemberShipOf(SetName2));ãEND;ããBEGIN (* Fuzzy-Logic-Unit *)ã (* Test auf Herculeskarte wg. Farbe fr Ergebnismengen *)ã Regs.ah:=15;ã Intr($10,Regs);ã IF Regs.AL=7 THEN (* Hercules-Karte *)ã BEGINã ResultCol :=Blue;ã DisplayOn :=FALSE; (* siehe Artikel c't 3/91 *)ã ENDã ELSE (* EGA-/VGA-Karte *)ã BEGINã ResultCol :=LightGray;ã DisplayOn :=TRUEã ENDãEND.ãã{ -------------------------- DEMO PROGRAM ------------------------ }ã{ I HOPE THAT YOU CAN READ GERMAN !! }ããprogram fuzzy_inf_demo; (* c't 3/91 / it / C.v.Altrock, RWTH Aachen *)ãuses Graph, Crt, Fuzzy;ãtype InputType = (temp,press,valve);ãvarã GraphDriver, GraphMode, RK : Integer;ã StepWidth : Array[InputType] OF Real;ã i,Input : InputType;ã Ch : Char;ã FuzzyVars : ARRAY[InputType] of FuzzyVarList;ããPROCEDURE InitGrafix;ã(* Grafikmodus initialisieren und Hilfetexte schreiben *)ãBEGINã GraphDriver := Detect;ã InitGraph(GraphDriver,GraphMode,'\turbo\tp');ã SetTextJustify(CenterText,CenterText);ã OutTextXY( GetMaxX DIV 2, 10, 'Demonstration der MAX-PROD-'ã +'Inferenz (c''t 3/91 / C.v.Altrock, RWTH Aachen)');ã OutTextXY( 500, 50, 'Eingabe Temperatur: ['+Chr(24)+']' );ã OutTextXY( 500, 65, 'Eingabe Druck: ['+Chr(25)+']' );ã OutTextXY( 500, 80, 'Erhhen: ['+Chr(26)+']' );ã OutTextXY( 500, 95, 'Vermindern: ['+Chr(27)+']' );ã OutTextXY( 500, 110, 'Schrittweite: [Bild'+Chr(24)+Chr(25)+']' );ã Rectangle(400,40,600,120);ãEND; (* InitGrafix *)ããbegin (* main *)ã InitGrafix;ãã (* Definition der linguistischen Variablen "Temperatur" *)ã FuzzyVars[temp]:= new(FuzzyVarList,ã Init('Temperatur',20,30,7,400,1000,650,'øC'));ã WITH FuzzyVars[temp]^ DOã BEGINã (* Definition und Anzeige der Fuzzy Sets *)ã DefineSet('niedrig',-Infinity,500,650,Blue);ã DefineSet('mittel',500,650,800,LightGreen);ã DefineSet('hoch',650,800,950,Red);ã DefineSet('sehr_hoch',800,950,Infinity,Yellow);ã DisplaySets; DisplayValue(ValueCol);ã END;ãã (* Definition der linguistischen Variablen "Druck" *)ã FuzzyVars[press]:= new(FuzzyVarList,ã Init('Druck',20,210,4,38,41,40,'bar'));ã WITH FuzzyVars[press]^ DOã BEGINã (* Definition und Anzeige der Fuzzy Sets *)ã DefineSet('unter_normal',-Infinity,39,40,Blue);ã DefineSet('normal',39,40,41,LightGreen);ã DefineSet('ber_normal',40,41,Infinity,Red);ã DisplaySets; DisplayValue(ValueCol);ã END;ãã (* Definition der linguistischen Variablen "Methanventil" *)ã FuzzyVars[valve]:= new(FuzzyVarList,ã Init('Methanventil',340,170,7,0,12,0,'m3/h'));ã WITH FuzzyVars[valve]^ DOã BEGINã (* Definition der Fuzzy Sets *)ã DefineSet('gedrosselt',-Infinity,0,4,Blue);ã DefineSet('halboffen',0,4,8,Green);ã DefineSet('mittel',4,8,12,LightGreen);ã DefineSet('offen',8,12,Infinity,Yellow);ã (* Definition der Inferenzregeln *)ã (* 1 IF Temperatur ist niedrig OR Druck ist unter_normalã THEN Methanventil ist offen *)ã DefineRule('offen',OR_MaxMax, FuzzyVars[temp],'niedrig',ã FuzzyVars[press],'unter_normal');ã (* 2 IF Temperatur ist sehr_hoch OR Druck ist ber_normalã THEN Methanventil ist gedrosselt *)ã DefineRule('gedrosselt',OR_MaxMax, FuzzyVars[temp],'sehr_hoch',ã FuzzyVars[press],'ber_normal');ã (* 3 IF Temperatur ist hoch AND Druck ist normalã THEN Methanventil ist halboffen *)ã DefineRule('halboffen',AND_MaxMin, FuzzyVars[temp],'hoch',ã FuzzyVars[press],'normal');ã (* 4 IF Temperatur ist mittel AND Druck ist normalã THEN Methanventil ist mittel *)ã DefineRule('mittel',AND_MaxMin, FuzzyVars[temp],'mittel',ã FuzzyVars[press],'normal');ã IF DisplayOn THEN DisplaySets;ã DisplayValue(ValueCol);ã Infer;ã Defuzzy;ã END;ãã SetColor( Red );ã OutTextXY( 540, 330, '(Resultat der Inferenz)' );ã (* Schrittweiten fr Druck und Temperatur intitialisieren *)ã StepWidth[temp]:=25;ã StepWidth[press]:=0.25;ãã Input:= temp;ã Ch := ReadKey;ã while Ch = #0 doã beginã RK := ord(ReadKey);ã if RK = 72 then input := tempã else if RK = 80 then input := pressã else if (RK=73) then StepWidth[input]:=StepWidth[input] * 2ã else if (RK=81) then Stepwidth[input]:= StepWidth[input] / 2ã else if (RK=75) OR (RK=77) thenã beginã (* 1. Eingangsvariable ndern *)ã if (RK=75) then FuzzyVars[Input]^.Change(-StepWidth[input])ã ELSE FuzzyVars[Input]^.Change(StepWidth[input]);ã (* 2. Inferenz durchfhren *)ã FuzzyVars[valve]^.Infer;ã (* 3. Ergebnismenge defuzzifizieren *)ã FuzzyVars[valve]^.Defuzzyã end;ã Ch := ReadKeyã end;ã CloseGraphãend.ã 88 02-03-9416:12ALL PHIL NICKELL Min/Max Words or IntegersIMPORT 16 o^² ã{$S-,R-}ãUNIT MaxMinW;ã(*ã The source code for the MaxMinW unit is released to the public domain.ã No rights are reserved. Phil Nickell. NSoft Co.ã This Turbo Pascal unit implements four highly optimized assemblyã language functions that provide MAX() and MIN() for unsigned words andã signed integersã*)ãINTERFACEã function MAXW (a,b:word) : Word; { max word }ã function MINW (a,b:word) : Word; { min word }ã function MAXI (a,b:integer) : Integer; { max integer }ã function MINI (a,b:integer) : Integer; { min integer }ããIMPLEMENTATIONãfunction maxw(a,b:word):word; Assembler;ã Asmã mov ax, a { first parm in ax }ã mov dx, b { second parm in dx }ã cmp ax, dx { compare parms }ã jae @1 { return 1st parm }ã mov ax, dx { return 2nd parm }ã @1:ã End;ããfunction minw(a,b:word):word; Assembler;ã Asmã mov ax, a { first parm in ax }ã mov dx, b { second parm in dx }ã cmp ax, dx { compare parms }ã jbe @1 { return 1st parm }ã mov ax, dx { return 2nd parm }ã @1:ã End;ããfunction maxi(a,b:integer):integer; Assembler;ã Asmã mov ax, a { first parm in ax }ã mov dx, b { second parm in dx }ã cmp ax, dx { compare parms }ã jge @1 { return 1st parm }ã mov ax, dx { return 2nd parm }ã @1:ã End;ããfunction mini(a,b:integer):integer; Assembler;ã Asmã mov ax, a { first parm in ax }ã mov dx, b { second parm in dx }ã cmp ax, dx { compare parms }ã jle @1 { return 1st parm }ã mov ax, dx { return 2nd parm }ã @1:ã End;ããBegin {INITIALIZATION}ãEnd.ã 89 02-03-9416:15ALL PHIL NICKELL Min/Max Longs in ASM IMPORT 31 oà ãUNIT MaxMinL;ã(*ã The source code MaxMinL unit is released to the public domain. Noã rights are reserved. Phil Nickell. NSoft Co.ã This Turbo Pascal unit implements five highly optimized assemblyã language functions that provide MAX() and MIN() for unsigned longwordã and signed longintegers, and also a function for an unsigned longwordã compare. The word functions treat the passed values as unsignedã values. The integer functions treat the passed values as signedã values. Turbo pascal does not have a LONGWORD data type, but theã MAXLW() and MINLW() functions treat the passed longint types asã unsigned words. Maxlw returns $ffffffff as greater than 0. Minlwã returns 0 as less than $ffffffff.ã*)ã{$r-,S-}ãINTERFACEã FUNCTION MAXLW (a,b:longint) : Longint; { max longword }ã FUNCTION MINLW (a,b:Longint) : Longint; { min longword }ã FUNCTION MAXLI (a,b:longint) : Longint; { max longint }ã function MINLI (a,b:Longint) : Longint; { min longint }ã function LWGT (a,b:Longint) : Boolean; { long > unsigned }ããIMPLEMENTATIONãfunction maxlw(a,b:longint):longint; Assembler; {long word}ã Asmã les ax, a { load longint to es:ax }ã mov dx, es { load longint to dx:ax }ã cmp dx, word ptr b+2 { cmp high words }ã ja @2 { high word > }ã jb @1 { high word < }ã cmp ax, word ptr b { comp low word }ã jae @2 { low word >= }ã @1: les ax, bã mov dx, es { load int to dx:ax }ã @2:ã End;ããfunction minlw(a,b:longint):longint; Assembler; { longword }ã Asmã les ax, a { load longint to es:ax }ã mov dx, es { load longint to dx:ax }ã cmp dx, word ptr b+2 { cmp high words }ã jb @2 { high word < }ã ja @1 { high word > }ã cmp ax, word ptr b { comp low word }ã jbe @2 { low word >= }ã @1: les ax, bã mov dx, es { load int to dx:ax }ã @2:ã End;ããfunction maxli(a,b:longint):longint; Assembler;ã Asmã les ax, a { load longint to es:ax }ã mov dx, es { load longint to dx:ax }ã cmp dx, word ptr b+2 { cmp high words }ã jg @2 { high word > }ã jl @1 { high word < }ã cmp ax, word ptr b { comp low word }ã jae @2 { low word >= }ã @1: les ax, bã mov dx, es { load int to dx:ax }ã @2:ã End;ããfunction minli(a,b:longint):longint; Assembler;ã Asmã les ax, a { load longint to es:ax }ã mov dx, es { load longint to dx:ax }ã cmp dx, word ptr b+2 { cmp high words }ã jl @2 { high word < }ã jg @1 { high word > }ã cmp ax, word ptr b { comp low word }ã jbe @2 { low word >= }ã @1: les ax, bã mov dx, es { load int to dx:ax }ã @2:ã End;ããfunction lwgt(a,b:longint):boolean; Assembler; {unsigned longword greater thanã}ã Asmã xor cx, cx { cx = 0 = false }ã les ax, a { load longint to es:ax }ã mov dx, es { load longint to dx:ax }ã cmp dx, word ptr b+2 { cmp high words }ã jb @2 { high word < }ã ja @1 { high word > }ã cmp ax, word ptr b { comp low word }ã jbe @2 { low word <= }ã @1: inc cx { cx = 1 = true }ã @2: mov ax, cx { load result to ax }ã End;ããBEGIN {INITIALIZATION}ãEND.ã 90 02-15-9407:54ALL BRIAN CORLL OOP Paradox Interface IMPORT 107 o {$F+,O+}ãUNIT OOPX;ã (**************************************)ã (* OOPX Version 1.00 *)ã (* Object-Oriented Interface for the *)ã (* Paradox Engine Version 2.0 *)ã (* and Turbo Pascal Version 6.0 *)ã (* Copyright 1991 Brian Corll *)ã (**************************************)ã (* Portions Copyright 1990-1991 *)ã (* Borland International *)ã (**************************************)ãããINTERFACEããUses PXEngine;ããããconstã PXError : Integer = PXSUCCESS;ã VarLong = 1;ã VarInt = 2;ã VarDate = 3;ã VarDoub = 4;ã VarAlpha = 5;ã VarShort = 6;ããtypeã DateRec = recordã M,D,Y : Integer;ã end;ããtypeã PXObject = objectã ErrCode : Integer;ã THandle : TableHandle;ã RHandle : RecordHandle;ã LHandles: Array[1..32] of LockHandle;ã SearchBuf : RecordHandle;ã LastLock: Byte;ã Name : String;ã RecNo : RecordNumber;ã Locked : Boolean;ã UnLocked: Boolean;ã constructor InitName(TblName : String);ã constructor InitOpen(TblName : String;ã IndexID : Integer;ã SaveEveryChange : Boolean);ã constructor InitCreate(TblName : String;ã NFields : Integer;ã Fields,Types : NamesArrayPtr);ã destructor Done;ã procedure ClearErrors;ã procedure LockRecord;ã procedure LockTable(LockType : Integer);ã procedure UnLockRecord;ã procedure UnLockTable(LockType : Integer);ã procedure RenameTable(FromName,ToName : String);ã procedure AddTable(AddTableName : String);ã procedure CopyTable(CopyName : String);ã procedure CreateIndex(NFlds : Integer;ã FldHandles : FieldHandleArray;ã Mode : Integer);ã procedure Encrypt(Password : String);ã procedure Decrypt(Password : String);ã procedure DeleteIndex(IndexID : Integer);ã procedure EmptyTable;ã procedure EmptyRecord;ã procedure ReadRecord;ã procedure InsertRecord;ã procedure AddRecord;ã procedure UpdateRecord;ã procedure DeleteRecord;ã procedure NextRecord;ã procedure PrevRecord;ã procedure GotoRecord(R : RecordNumber);ã procedure Flush;ã procedure SearchField(FHandle : FieldHandle;Mode : Integer);ã procedure SearchKey(NFlds : Integer;Mode : Integer);ã procedure InitSearchBuf(FldName : NameString;var Variable;VarType : Byte);ã procedure PutField(FldName : NameString;var Variable);ã procedure PutLongField(FldName : NameString;var L : Longint);ã procedure GetField(FldName : NameString;var Variable);ã procedure GetLongField(FldName : NameString;var L : Longint);ã function FieldNumber(FldName : NameString) : Integer;ã function FieldName(FHandle : FieldHandle) : NameString;ã function FieldType(FHandle : FieldHandle) : NameString;ã function IsBlank(FldName : NameString) : Boolean;ã function TableChanged : Boolean;ã procedure Refresh;ã procedure Top;ã procedure Bottom;ã function GetRecordNumber : Longint;ã end;ãããfunction PXOk : Boolean;ããIMPLEMENTATIONãã function PXOk : Boolean;ã beginã PXOk := (PXError = PXSUCCESS);ã end;ãã constructor PXObject.InitName;ã beginã Name := TblName;ã end;ãã constructor PXObject.InitOpen;ã beginã THandle := 0;ã Name := '';ã ErrCode := PXTblOpen(TblName,ã THandle,ã IndexID,ã SaveEveryChange);ã If ErrCode = PXSUCCESS thenã beginã Name := TblName;ã ErrCode := PXRecBufOpen(THandle,RHandle);ã ErrCode := PXRecBufOpen(THandle,SearchBuf);ã end;ã LastLock := 0;ã FillChar(LHandles,32,0);ã PXError := ErrCode;ã Locked := False;ã UnLocked := False;ã end;ãã constructor PXObject.InitCreate(TblName : String;ã NFields : Integer;ã Fields,Types : NamesArrayPtr);ã beginã ErrCode := PXTblCreate(TblName,NFields,Fields,Types);ã PXError := ErrCode;ã end;ãã procedure PXObject.Encrypt(Password : String);ã beginã ErrCode := PXTblEncrypt(Name,Password);ã If ErrCode = PXERR_TABLEOPEN thenã beginã ErrCode := PXTblClose(THandle);ã If ErrCode = PXSUCCESS thenã ErrCode := PXTblEncrypt(Name,Password);ã end;ã PXError := ErrCode;ã end;ãã procedure PXObject.ClearErrors;ã beginã ErrCode := 0;ã PXError := 0;ã end;ãã procedure PXObject.Decrypt(Password : String);ã beginã ErrCode := PXPswAdd(Password);ã If ErrCode = PXSUCCESS thenã beginã ErrCode := PXTblDecrypt(Name);ã If ErrCode = PXERR_TABLEOPEN thenã beginã ErrCode := PXTblClose(THandle);ã If ErrCode = PXSUCCESS thenã ErrCode := PXTblDecrypt(Name);ã end;ã end;ã PXError := ErrCode;ã end;ãã procedure PXObject.CreateIndex(NFlds : Integer;ã FldHandles : FieldHandleArray;ã Mode : Integer);ã beginã ErrCode := PXKeyAdd(Name,NFlds,FldHandles,Mode);ã PXError := ErrCode;ã end;ãã procedure PXObject.DeleteIndex;ã beginã ErrCode := PXKeyDrop(Name,IndexID);ã PXError := ErrCode;ã end;ãã procedure PXObject.Flush;ã beginã ErrCode := PXSave;ã PXError := ErrCode;ã end;ãã procedure PXObject.LockRecord;ã var LockTest : Boolean;ã beginã Locked := False;ã Inc(LastLock);ã ErrCode := PXNetRecLock(THandle,LHandles[LastLock]);ã ErrCode := PXNetRecLocked(THandle,LockTest);ã Locked := (ErrCode = PXSUCCESS)ã and LockTest;ã If not Locked then Dec(LastLock);ã PXError := ErrCode;ã end;ãã procedure PXObject.LockTable;ã beginã Locked := False;ã ErrCode := PXNetTblLock(THandle,LockType);ã Locked := (ErrCode = PXSUCCESS);ã PXError := ErrCode;ã end;ãã procedure PXObject.UnLockRecord;ã beginã UnLocked := False;ã ErrCode := PXNetRecUnlock(THandle,LHandles[LastLock]);ã If (ErrCode = PXSUCCESS) thenã beginã UnLocked := True;ã LHandles[LastLock] := 0;ã Dec(LastLock);ã end;ã end;ãã procedure PXObject.UnLockTable(LockType : Integer);ã beginã UnLocked := False;ã ErrCode := PXNetTblUnlock(THandle,LockType);ã PXError := ErrCode;ã UnLocked := (PXError = PXSUCCESS);ã end;ãã procedure PXObject.RenameTable(FromName,ToName : String);ã beginã ErrCode := PXTblRename(FromName,ToName);ã PXError := ErrCode;ã end;ãã procedure PXObject.AddTable(AddTableName : String);ã beginã ErrCode := PXTblAdd(AddTableName,Name);ã PXError := ErrCode;ã end;ãã procedure PXObject.CopyTable(CopyName : String);ã beginã ErrCode := PXTblCopy(Name,CopyName);ã PXError := ErrCode;ã end;ãã procedure PXObject.EmptyTable;ã beginã ErrCode := PXTblEmpty(Name);ã PXError := ErrCode;ã end;ãã procedure PXObject.EmptyRecord;ã beginã ErrCode := PXRecBufEmpty(RHandle);ã PXError := ErrCode;ã end;ãã procedure PXObject.ReadRecord;ã beginã ErrCode := PXRecGet(THandle,RHandle);ã PXError := ErrCode;ã end;ãã procedure PXObject.InsertRecord;ã beginã ErrCode := PXRecInsert(THandle,RHandle);ã PXError := ErrCode;ã end;ãã procedure PXObject.AddRecord;ã beginã ErrCode := PXRecAppend(THandle,RHandle);ã PXError := ErrCode;ã end;ãã procedure PXObject.UpdateRecord;ã beginã ErrCode := PXRecUpdate(THandle,RHandle);ã PXError := ErrCode;ã end;ãã procedure PXObject.DeleteRecord;ã beginã ErrCode := PXRecDelete(THandle);ã PXError := ErrCode;ã end;ãã procedure PXObject.NextRecord;ã beginã ErrCode := PXRecNext(THandle);ã PXError := ErrCode;ã end;ãã procedure PXObject.PrevRecord;ã beginã ErrCode := PXRecPrev(THandle);ã PXError:= ErrCode;ã end;ãã procedure PXObject.GotoRecord(R : RecordNumber);ã beginã ErrCode:= PXRecGoto(THandle,R);ã PXError := ErrCode;ã end;ãã procedure PXObject.PutField(FldName : NameString;var Variable);ã var FType : NameString;ã FirstChar : Char;ã FHandle : FieldHandle;ã beginã FHandle := FieldNumber(FldName);ã If (PXError <> PXSUCCESS) then Exit;ã ErrCode := PXFldType(THandle,FHandle,FType);ã FirstChar := FType[1];ã case FirstChar ofã 'D' : ErrCode := PXPutDate(RHandle,FHandle,TDate(Variable));ã 'A' : ErrCode := PXPutAlpha(RHandle,FHandle,String(Variable));ã '$','N'ã : ErrCode := PXPutDoub(RHandle,FHandle,Double(Variable));ã 'S' : ErrCode := PXPutShort(RHandle,FHandle,Integer(Variable));ã end;ã PXError := ErrCode;ã end;ãã procedure PXObject.InitSearchBuf(FldName : NameString;var Variable;VarType : Byte);ã var FHandle : FieldHandle;ã beginã FHandle := FieldNumber(FldName);ã If (PXError <> PXSUCCESS) then Exit;ã case VarType ofã VarDate : ErrCode := PXPutDate(SearchBuf,FHandle,TDate(Variable));ã VarAlpha : ErrCode := PXPutAlpha(SearchBuf,FHandle,String(Variable));ã VarDoub : ErrCode := PXPutDoub(SearchBuf,FHandle,Double(Variable));ã VarShort : ErrCode := PXPutShort(SearchBuf,FHandle,Integer(Variable));ã VarLong : ErrCode := PXPutLong(SearchBuf,FHandle,Longint(Variable));ã end;ã PXError := ErrCode;ã end;ãã procedure PXObject.PutLongField(FldName : NameString;var L : Longint);ã var FHandle : FieldHandle;ã beginã FHandle := FieldNumber(FldName);ã If (PXError <> PXSUCCESS) then Exit;ã ErrCode := PXPutLong(RHandle,FHandle,L);ã PXError := ErrCode;ã end;ãã procedure PXObject.GetField(FldName : NameString;var Variable);ã var FType : NameString;ã FirstChar : Char;ã FHandle : FieldHandle;ã beginã FHandle := FieldNumber(FldName);ã If (PXError <> PXSUCCESS) then Exit;ã ErrCode := PXFldType(THandle,FHandle,FType);ã FirstChar := FType[1];ã case FirstChar ofã 'D' : ErrCode := PXGetDate(RHandle,FHandle,TDate(Variable));ã 'A' : ErrCode := PXGetAlpha(RHandle,FHandle,String(Variable));ã '$','N'ã : ErrCode := PXGetDoub(RHandle,FHandle,Double(Variable));ã 'S' : ErrCode := PXGetShort(RHandle,FHandle,Integer(Variable));ã end;ã PXError := ErrCode;ã end;ãã procedure PXObject.GetLongField(FldName : NameString;var L : Longint);ã var FHandle : FieldHandle;ã beginã FHandle := FieldNumber(FldName);ã If (PXError <> PXSUCCESS) then Exit;ã ErrCode := PXGetLong(RHandle,FHandle,L);ã PXError := ErrCode;ã end;ãã function PXObject.GetRecordNumber : Longint;ã beginã ErrCode := PXRecNum(THandle,RecNo);ã If (ErrCode = PXSUCCESS) thenã GetRecordNumber := RecNo;ã PXError := ErrCode;ã end;ãã function PXObject.FieldNumber(FldName : NameString) : Integer;ã var FldHandle : FieldHandle;ã beginã ErrCode := PXFldHandle(THandle,FldName,FldHandle);ã If (ErrCode = PXSUCCESS) then FieldNumber := FldHandleã else FieldNumber := 0;ã PXError := ErrCode;ã end;ãã function PXObject.IsBlank(FldName : NameString) : Boolean;ã var Blank : Boolean;ã FHandle : FieldHandle;ã beginã FHandle := FieldNumber(FldName);ã If (ErrCode <> PXSUCCESS) then PX(PXError);ã IsBlank := False;ã ErrCode := PXFldBlank(RHandle,FHandle,Blank);ã If ErrCode = PXSUCCESS then IsBlank := Blank;ã PXError := ErrCode;ã end;ãã function PXObject.TableChanged : Boolean;ã var Changed : Boolean;ã beginã TableChanged := False;ã ErrCode := PXNetTblChanged(THandle,Changed);ã If ErrCode = PXSUCCESS thenã TableChanged := Changed;ã PXError := ErrCode;ã end;ãã procedure PXObject.Refresh;ã beginã ErrCode := PXNetTblRefresh(THandle);ã PXError := ErrCode;ã end;ãã function PXObject.FieldName(FHandle : FieldHandle) : NameString;ã var FName : NameString;ã beginã ErrCode := PXFldName(THandle,FHandle,FName);ã If ErrCode = PXSUCCESS thenã FieldName := FNameã elseã FIeldName := '';ã PXError := ErrCode;ã end;ãã procedure PXObject.SearchField(FHandle : FieldHandle;Mode : Integer);ã beginã ErrCode := PXSrchFld(THandle,SearchBuf,FHandle,Mode);ã PXError := ErrCode;ã end;ãã procedure PXObject.SearchKey(NFlds : Integer;Mode : Integer);ã beginã ErrCode := PXSrchKey(THandle,SearchBuf,NFlds,Mode);ã PXError := ErrCode;ã end;ãã function PXObject.FieldType(FHandle : FieldHandle) : NameString;ã var FType : NameString;ã beginã FieldType := '';ã ErrCode := PXFldType(THandle,FHandle,FType);ã If ErrCode = PXSUCCESS then FieldType := FType;ã PXError := ErrCode;ã end;ãã procedure PXObject.Top;ã beginã ErrCode := PXRecFirst(THandle);ã PXError := ErrCode;ã end;ãã procedure PXObject.Bottom;ã beginã ErrCode := PXRecLast(THandle);ã PXError := ErrCode;ã end;ããã destructor PXObject.Done;ã beginã ErrCode := PXRecBufClose(RHandle);ã ErrCode := PXRecBufClose(SearchBuf);ã ErrCode := PXTblClose(THandle);ã PXError := ErrCode;ã end;ããbeginãend.ããã
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/