SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00099 ANYTHING NOT OTHERWISE CLASSIFIED 1 05-28-9313:51ALL SWAG SUPPORT TEAM BOOKISBN.PAS IMPORT 14 èo╠─ {π For you Programming librarians: the following Turbo Pascal Programπ will verify any ISBN (International Standard Book Number).π}π(*******************************************************************)π Program VerifyISBN; { Verify any ISBN number. Turbo Pascal }π { 1992, 1993 Greg Vigneault }ππ Var ISBNstr : String[16];π loopc, ISBNlen, M, chksm : Byte;π beginπ WriteLn; WriteLn( 'ISBN Verification v0.1, Greg Vigneault',#10);ππ if ( ParamCount <> 1 ) then begin { we want just 1 input parm }π WriteLn( 'Syntax: ISBN <ISBN#>',#7 );π Halt(1);π end;π ISBNstr := ParamStr(1); { get ISBN# String }π Write( 'Checking ISBN# ', ISBNstr );π { eliminate any non-digit Characters from the ISBN String... }π ISBNlen := 0;π For loopc := 1 to orD( ISBNstr[0] ) doπ if ( ISBNstr[ loopc ] in ['0'..'9'] ) then beginπ inC( ISBNlen );π ISBNstr[ ISBNlen ] := ISBNstr[ loopc ];π end;π { an 'X' at the end of the ISBN affects the result }π if ( ISBNstr[ orD( ISBNstr[0] ) ] in ['X','x'] )π then M := 10π else M := orD( ISBNstr[ ISBNlen ] ) - 48;π ISBNstr[0] := CHR( ISBNlen ); { new ISBN str length }π chksm := 0;π For loopc := 1 to ISBNlen-1 doπ inC( chksm, ( orD( ISBNstr[ loopc ] ) - 48 ) * loopc );π Write( ' <--- ' );π if ( ( chksm MOD 11 ) = M )π then WriteLn( 'Okay' )π else WriteLn( 'ERRor!',#7 );π end {VerifyISBN}.π(********************************************************************)π 2 05-28-9313:51ALL SWAG SUPPORT TEAM CPAS-OBJ.PAS IMPORT 5 èolM REYNIR STEFANSSONππ> Does anyone know of any way to convert a .TPU to a .BIN File toπ> use BIN2OBJ.EXE and then load it as an external? Any helpπ> appreciated...ππIt's a bit round-the-block, but you might get some exercise out of it,πassuming you have the source code:ππ1) Smash the source into C With a code converter.ππ2) Declare the Procedures as `void far PASCAL' and the Functions asπ `appropriate_Type far PASCAL'.ππ3) Compile it With Turbo C or similar.ππ 3 05-28-9313:51ALL SWAG SUPPORT TEAM DBASE4.PRG IMPORT 39 èo─Æ {πHello every one... Guys and gals is there any such a thing that you canπuse turbp pascal 6 with Dbase IV.. what I heard is I can.πif yes tell me how you export or whatever to use two of thewmπtogether,,,ππYes there is! I have been using it for some time now in dBase as I useπan XT and dBase's editor is too slow when the program has quite a fewπlines (some are 5,000) and the system just kind of dies. When I use TP'sπIDE the editor is FAST!!!! So after reading the books I designed aπprogram in order to use TP as using it in the TEDIT CONFIG.DB commandπwouldn't work as it needed more memory (I only have 640k).π}πππIn dBase's setup program, under the FILES MENU enter in eitherπPRGAPPLIC (overrides Application Control in the ASSIST menu only!) orπ Entry - C:\DBASEIV\EDIT2.PRGπ Exit - emptyπ Layout - emptyπPRGCC (allows you to use OPEN CUSTOM UTILIY option under Catalog Menu).π Entry - emptyπ Exit - emptyπ Layout - C:\DBASEIV\EDIT2.PRGππI am currently using PRGAPPLIC as I do most of my work in the ControlπCenter anyhow and don't need the Application Generator. Note - PRGCCπwill not pull in a PRG file unless you change the source code to ask forπone.ππHere is the dBase program that calls Turbo Pascal:ππ* <T>Program ----> EDIT2.PRGπ* <D>Language ---> dBase IV 1.5π* <P>Author -----> P.A.T. Systems° C.1993π* <T>Creation date -> 07/22/1992π* <L>Last update ---> 01/06/1993ππ* <G>From-> Control Centerπ* <N>To---> Noneπ* <T>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 <options> <Filename>');π 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 (thaco@solan.Unit.no).');π 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 ParamCount<Counter thenπ beginπ WriteLn('ERRor! No Filename specified.');π Halt(0);π end;ππ FileName:=UpCaseString(ParamStr(Counter));π if Pos('.',FileName)=0 then { find out if there exist a . in the Filename }π FileName:=FileName+'.FLI'; { if not then add the .FLI extension on the Filename }ππ if MaxAvail<BUFFERSIZE then { check if there is enough memory to the frame buffer }π beginπ WriteLn('ERRor! Can not allocate enough memory to a frame buffer.');π Halt(0);π end;ππ GetMem(Buffer,BUFFERSIZE);π Assign(InputFile,FileName);π Reset(InputFile,1);π if Ioresult<>0 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 TimeCounter<NextTime do { wait For this long }π TimeCounter:=GetClock;ππ if PorT[$64]=KEYBOARD then { check if the value at the keyboard port is caused by a key pressed }π Key:=PorT[$60]; { get the current value from the keyboard }π Inc(FrameNumber); { one frame finished, over to the next one }π Until (FrameNumber>Frames) 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 jallen@ic.sunysb.edu}π{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)<h doπ s := concat(s,' ');π fpad := s;πend;πππProcedure pad(Var s:String;h:Integer);πbeginπ While length(s)<h doπ s := concat(s,' ');πend;πππFunction between(x,x1,x2:Integer):Boolean;πbeginπ between := ((x>=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: colin.buckley@rose.com |π| |π| 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<Pred(Size)) and Valid doπ beginπ Index2 := Index1 + 1;π While (Index2 < Size) and Valid doπ beginπ if Specimen[Index1] = Specimen[Index2] thenπ Valid := False;π inc(Index2);π end;π inc(Index1);π end;π IsAnagram := Valid;πend;ππProcedure FindAnagrams(Target : AnagramStr;π Var Specimen : AnagramArray; Size : Word);πVarπ Index : Word;π Carry : Boolean;πbeginπ Repeatπ working;π if IsAnagram(Specimen, Size) thenπ beginπ OutputAnagram(Target, Specimen, Size);π inc(AnagramCount);π end;π Index := 0;π Repeatπ Specimen[Index] := (Specimen[Index] + 1) mod Size;π Carry := not Boolean(Specimen[Index]);π Inc(Index);π Until (not Carry) or (Index >= 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<<smile>>... 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╒σ {πrandyd@csd4.csd.uwm.edu (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 <April 21,1992> *)ππ{$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:;<=>?@ABC...XYZ[\]^_ππ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 TDARCOS@MCIMAIL.COMπ 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 - TDARCOS@MCIMAIL.COM');π 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 èoÇ2 {π 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 <g>ππ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 <Enter> key to toggle (like the <SpaceBar>) and useπ<F10> 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 <Enter>π key to its original setting and gets rid of the <F10> 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╬ {πpigeons@JSP.UMontreal.CA (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 a<bπ then min:=aπ else min:=b;π end;ππ procedure mark(x,y:integer);π var t,g,i:integer;π beginπ for t:=y+1 to top do inc(attaques[x,t]);ππ t:=x+1;π g:=y+1;ππ for i:=1 to min(top-t,top-g)+1 doπ beginπ inc(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π 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 (j<top) do inc(j);π if (attaques[j,level]=libre)π then find:=jπ else find:=0;π end;ππππ procedure recurse(level:integer);π var t:integer;π beginπ inc(recursions);π t:=0;π repeatπ t:=find(level,t);π if t<>0π 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 èoôX {π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 <filename>');π 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 èoïG {π> 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 *)π (* Zugehörigkeit *)π Rules : FuzzyRuleList; (* Regelliste für 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 für UND *)πFUNCTION AND_MaxMin(Set1,Set2,Set3:Real):Real;πBEGINπ AND_MaxMin:=Max(Set1,Min(Set2,Set3))πEND;ππ(* MaxMax-Operator für 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 Flächenschwerpunktes der unscharfen *)π(* Ergebnismenge durch Auszählen 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 (* Flächenschwerpunkt 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 für 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, 'Erhöhen: ['+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 für 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 durchführen *)π 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.πππ 91 05-25-9408:01ALL BJÖRN FELTEN Going International SWAG9405 39 èo unit CaseUtil;ππinterfaceππtypeπ DelimType =π recordπ thousands,π decimal,π date,π time : array[0..1] of Char;π end;ππ CurrType = (leads, { symbol precedes value }π trails, { value precedes symbol }π leads_, { symbol, space, value }π _trails, { value, space, symbol }π replace); { replaced }ππ CountryType =π recordπ DateFormat : Word; { 0: USA, 1: Europe, 2: Japan }π CurrSymbol : array[0..4] of Char;π Delimiter : DelimType; { Separators }π CurrFormat : CurrType; { Way currency is formatted }π CurrDigits : Byte; { Digits in currency }π Clock24hrs : Boolean; { True if 24-hour clock }π CaseMapCall : procedure; { Lookup table for ASCII > $80 }π DataListSep : array[0..1] of Char;π CID : word;π Reserved : array[0..7] of Char;π end;ππ CountryInfo =π recordπ case InfoID: byte ofπ 1: (IDSize : word;π CountryID : word;π CodePage : word;π TheInfo : CountryType);π 2: (UpCaseTable: pointer);π end;ππvarπ CountryOk : Boolean; { Could determine country code flag }π CountryRec : CountryInfo;ππfunction Upcase(c : Char) : Char;πfunction LoCase(c : Char) : Char;πfunction UpperStr(s : string) : string;πfunction LowerStr(s : string) : string;πprocedure UpCaseStr(var s : String);πprocedure LoCaseStr(var s : String);ππimplementationππ{$R-,S-,V- }πvarπ LoTable : array[0..127] of byte;π CRP, LTP : pointer;ππ { Convert a character to upper case }π function Upcase; Assembler; asmπ mov al, cπ cmp al, 'a'π jb @2π cmp al, 'z'π ja @1π sub al, ' 'π jmp @2π@1: cmp al, 80hπ jb @2π sub al, 7ehπ push dsπ lds bx,CountryRec.UpCaseTableπ xlatπ pop dsπ@2:π end; { UpCase }ππ { Convert a character to lower case }π function LoCase; Assembler; asmπ mov al, cπ cmp al, 'A'π jb @2π cmp al, 'Z'π ja @1π or al, ' 'π jmp @2π@1: cmp al, 80hπ jb @2π sub al, 80hπ mov bx,offset LoTableπ xlatπ@2:π end; { LoCase }ππ { Convert a string to uppercase }π procedure UpCaseStr; Assembler; asmπ cldπ les di, sπ xor ax, axπ mov al, es:[di]π stosbπ xchg ax, cxπ jcxz @4π push dsπ lds bx,CountryRec.UpCaseTableπ@1: mov al, es:[di]π cmp al, 'a'π jb @3π cmp al, 'z'π ja @2π sub al, ' 'π jmp @3π@2: cmp al, 80hπ jb @3π sub al, 7ehπ xlatπ@3: stosbπ loop @1π pop dsπ@4:π end; { UpCaseStr }ππ { Convert a string to lower case }π procedure LoCaseStr; Assembler; asmπ cldπ les di, sπ xor ax, axπ mov al, es:[di]π stosbπ xchg ax, cxπ jcxz @4π@1: mov al, es:[di]π cmp al, 'A'π jb @3π cmp al, 'Z'π ja @2π or al, ' 'π jmp @3π@2: cmp al, 80hπ jb @3π sub al, 80hπ mov bx, offset LoTableπ xlatπ@3: stosbπ loop @1π@4:π end; { LoCaseStr }ππfunction UpperStr(s : string) : string;πbegin UpCaseStr(s); UpperStr:=s end;πfunction LowerStr(s : string) : string;πbegin LoCaseStr(s); LowerStr:=s end;ππbegin { init DoCase unit }π CRP := @CountryRec;π LTP := @LoTable;π asmππ { Exit if Dos version < 3.0 }π mov ah, 30hπ int 21hπ cmp al, 3π jb @1ππ { Call Dos 'Get country dependent information' function }π mov ax, 6501hπ les di, CRPπ mov bx,-1π mov dx,bxπ mov cx,41π int 21hπ jc @1ππ { Call Dos 'Get country dependent information' function }π mov ax, 6502hπ mov bx, CountryRec.CodePageπ mov dx, CountryRec.CountryIDπ mov CountryRec.TheInfo.CID, dxπ mov cx, 5π int 21hπ jc @1ππ { Build LoCase table }π les di, LTPπ mov cx, 80hπ mov ax, cxπ cldπ@3:π stosbπ inc axπ loop @3π mov di, offset LoTable - 80hπ mov cx, 80hπ mov dx, cxπ push dsπ lds bx, CountryRec.UpCaseTableπ sub bx, 7ehπ@4:π mov ax, dxπ xlatπ cmp ax, 80hπ jl @5π cmp dx, axπ je @5π xchg bx, axπ mov es:[bx+di], dlπ xchg bx, axπ@5:π inc dxπ loop @4π pop dsπ mov [CountryOk], Trueπ jmp @2π@1: mov [CountryOk], Falseπ@2:π end;πend.π 92 05-25-9408:01ALL CAMERON CLARK Credit Card check SWAG9405 27 èo π {$F+,D+,L+}ππunit Vericard;ππinterfaceππ function Vc(c : string) : char;ππimplementationππ function Vc(c : string) : char;π varπ card : string[21];π Vcard : array[0..21] of byte absolute card;π Xcard : integer;π Cstr : string[21];π y, x : integer;π beginπ x := 0;π Cstr := ' ';π Cstr := '';π fillchar(Vcard, 22, #0);π card := c;π for x := 1 to 20 doπ if (Vcard[x] in [48..57]) thenπ Cstr := Cstr + chr(Vcard[x]);π card := '';π card := Cstr;π Xcard := 0;π if NOT odd(length(card)) thenπ for x := (length(card) - 1) downto 1 doπ beginπ if odd(x) thenπ y := ((Vcard[x] - 48) * 2)π elseπ y := (Vcard[x] - 48);π if (y >= 10) thenπ y := ((y - 10) + 1);π Xcard := (Xcard + y)π endπ elseπ for x := (length(card) - 1) downto 1 doπ beginπ if odd(x) thenπ y := (Vcard[x] - 48)π elseπ y := ((Vcard[x] - 48) * 2);π if (y >= 10) thenπ y := ((y - 10) + 1);π Xcard := (Xcard + y)π end;π x := (10 - (Xcard mod 10));π if (x = 10) thenπ x := 0;π if (x = (Vcard[length(card)] - 48)) thenπ Vc := Cstr[1]π elseπ Vc := #0π end;ππEND.ππ{ .....................DRIVER EXAMple........ }ππ{$A-,B+,D-,E-,F-,I+,L-,N-,O-,R+,S+,V+}π{$M 2048,0,4096}ππprogram ValiCard;ππ { Test routine for the Mod 10 Check Digit CC validator... }ππusesπ dos,π crt,π VeriCard;ππvarπ card : string[22];π k : char;ππ procedure Squawk(Noise : byte);π beginπ case Noise ofπ 1 : beginπ Sound(400);π Delay(200);π Sound(200);π Delay(200);π Nosoundπ end;π 2 : beginπ Sound(392);π Delay(55);π Nosound;π Delay(30);π Sound(523);π Delay(55);π Nosound;π Delay(30);π Sound(659);π Delay(55);π Nosound;π Delay(30);π Sound(784);π Delay(277);π Nosound;π Delay(30);π Sound(659);π Delay(55);π Nosound;π Delay(30);π Sound(784);π Delay(1200);π Nosoundπ endπ end { case }π end;ππBEGINπ k := #0;π clrscr;π fillchar(card, 22, #0);π writeln('VC: Integer Modulo-10 Visa/Mastercard/Amex Check-Digit');π writeln(' verification routine. (c) 1990 Daniel J. Karnes');π writeln;π write(' Please enter a Credit Card number: ');π readln(card);π writeln;π writeln;π if (length(card) > 12) thenπ k := Vc(card);π if (k in ['3', '4', '5']) thenπ Squawk(2)π elseπ Squawk(1);π case k ofπ #0 : writeln(' Could NOT verify this number with any card type.')π '3' : writeln(' Card was verified as a valid Amex Card Number.');π '4' : writeln(' Card was verified as a valid VISA Card Number.');π '5' : writeln(' Card was verified as a valid Mastercard Number.')π endπEND.ππ...................πHope that helps. I've only tried it on one card number BUT it did workπfor the one and the info was received from someone in the business.π 93 05-25-9408:02ALL CHRIS LAUTENBACH Various Cool Routines SWAG9405 59 èo {π After looking around through some of my routines, I found a few that wereπ generic enough that they might be of use to the rest of ya.ππ My only request is that if you modify them and make them any cooler thanπ they already are -- send me back a copy. Oh -- yeah -- and if you useπ them in your programs give me credit, or at least a registered copy. :)ππ Here's a brief rundown of these routines:ππ proc SeqRen - renames a file, keep a certain number of backups.π EG: When you download a file, and one already exists,π it renames them. Only thing is, that this keeps themπ in age order. :)ππ func Filetype - determines the type of a file. Right now, it onlyπ knows about ZIP, ARJ, LHA, EXE and GIF files. If youπ can expand on this, feel free - and make sure youπ mail me back a copy of the new ones! :)ππ func FileExistWild - takes a wildcard filename and determines if any filesπ matching that spec are present. (Eg: *.EXE) Theπ filename doesn't even have to be a wildcard, so youπ could use this as a generic function to see if a fileπ exists or not.ππ func SizeFile - takes a filename as input, and if the file exists, itπ returns the size of the file. Returns -1 if fileπ does not exist.ππ funct SwtVal - returns the value of a command line switch. Forπ example, on a 'comms' (I hate that) program you mightπ want to be able to specify an alternate COM: port onπ the command line. With this routine you could do thatπ easily, just check for SwtVal('/COM:'). If theπ result is anything other than an empty string, thenπ that is the value. You can specify multiple wordsπ per command line parameter by replacing the spacesπ with underscores ('_').ππ func StatusBar - You've all seen those programs which display thoseπ nifty progress bars as they do things. Now you canπ do it too! Simply call this with the total number ofπ items (eg: the file size say 10 records for example)π and the current item (eg: record 4 out of 10 records)π and StatusBar will return a demi-hi-res progress barπ as a string. :)ππ func EraseFiles - Erases all the files in with a filespec matching theπ one it is passed. Example: EraseFiles('*.BAK') wouldπ delete all files with the .BAK extension in theπ current directory.π}ππprocedure SeqRen(Fn : string; Max : byte);π{ Sequentially rename file Fn, keeping Max number of files }πvar idx, rn : byte;π sfn, efn, ofn : string;π Rend, whole : boolean;π f : file;ππ function Merge(st:string; ln:longint):string;π var tmp : string;π beginπ tmp:=Long2Str(ln);π if length(tmp)>1 thenπ beginπ st[length(st)-1]:=tmp[1];π st[length(st)]:=tmp[2];π endπ elseπ st[length(st)]:=tmp[1];π Merge:=St;π end;ππbeginπ Rend:=false;whole:=false;idx:=0; { Set up variables }ππ If pos('.',fn)>0 then { Disect the filename }π beginπ sfn:=copy(fn,1,pos('.',fn)-1);π efn:=copy(fn,pos('.',fn)+1,length(fn));π endπ ELSEπ whole:=true;π repeatπ Inc(idx);π if not ExistFile(sfn+'.'+Merge(efn, idx)) then rend:=true;π until (idx=max) or Rend;ππ if (idx=max) and (rend=false) then { Nope? Okay, no problem. }π beginπ Assign(f,sfn+'.'+Merge(efn, max)); { Rename all oldies and make }π Erase(f); { room for it as number 1 }π for idx:=(max-1) downto 1 doπ beginπ Assign(f,sfn+'.'+Merge(efn, idx));π Rename(f,sfn+'.'+Merge(efn, idx+1));π end;π rn:=1;π end;ππ if rend then rn:=idx;ππ Assign(f,fn); { Rename the requested file! }π Rename(f,sfn+'.'+Merge(efn, rn));πend;ππType FileIDType = (fEXE, fZIP, fARJ, fLHA, fGIF87);ππfunction FileType(Filename : string) : FileIDType;π{ This function attempts to identify what type of a file Filename is }πvar Infile : file;π IdBytes : Array[1..10] of char;π SubId : string;πbeginπ FileType := fUnknown;π If NOT ExistFile(FileName) then Exit;π Assign(Infile, FileName);π Reset(Infile, 1);π If (FileSize(Infile) = 0) thenπ beginπ Close(Infile);π Exit;π end;π BlockRead(Infile, IDBytes, 10);π Close(Infile);π SubId := Copy(IDBytes, 1, 2);π If (SubID = 'MZ') then FileType := fEXEπ ELSEπ If (SubID = 'PK') then FileType := fZIPπ ELSEπ if (SubID = #96 + #234) then FileType := fARJπ ELSEπ If (Copy(IDBytes, 3, 5) = '-lh5-') then FileType := fLHAπ ELSEπ If (Copy(IDBytes, 3, 5) = '-lh1-') then FileType := fLHAπ ELSEπ if (Copy(IDbytes, 1, 5) = 'GIF89a') then FileType := fGIF87;πend;ππfunction FileExistWild(Mask : string) : boolean; { Does X*.* exist? :) }πvar sr : SearchRec;πbeginπ FindFirst(Mask, AnyFile, SR);π If DosError<>18 thenπ FileExistWild := TRUEπ ELSEπ FileExistWild := FALSE;πend;ππFunction SizeFile(Fname : string) : longint;πvar sr : SearchRec;π idx : integer;πbeginπ SizeFile := 0;π Findfirst(Fname, Anyfile, SR);π If DosError = 0 then SizeFile := SR.Size ELSE SizeFile := -1;πend;ππfunction SwtVal(Swt : string) : string;π{ Returns the value of a command line switch. Eg: for /COM:2, callπ SwtVal('/COM2:') and it will return 2. }πvar ndx, found : byte;π st : string;πbeginπ Found := 0;π For ndx := 1 to ParamCount doπ beginπ if StUpCase(copy(paramstr(ndx), 1, length(swt))) = StUpCase(swt) thenπ beginπ Found := ndx;π Break;π end;π end;π if (Found = 0) thenπ beginπ swtval := '';π Exit;π end;π st := '';π st := StUpCase(Copy(ParamStr(Found), Length(Swt) + 1,π Length(ParamStr(Found)) - Length(Swt)));π For ndx := 1 to Length(St) doπ if (St[ndx] = '_') then St[ndx] := #32;π SwtVal := st;πend;ππFunction StatusBar(total, amt : longint) : string;πConst BarLength = 40;πvar a, b, c, d : longint;π percent : real;π st : string;πbeginπ If (total = 0) OR (amt = 0) thenπ beginπ StatusBar := '';π Exit;π end;π if (Amt > Total) then amt := total;π Percent := Amt / Total * (Barlength * 10);π a := trunc(percent);π b := a div 10;π c := 1;π percent := amt / total * 100;π d := trunc(percent);π st := ' (' + int_to_str(d) + '%)';π StatusBar := CharStr(b * c, #219) + CharStr(Barlength - (b * c), #176) + st;πend;ππfunction EraseFiles(Path, Mask : string) : integer;πvar S : SearchRec;πbeginπ FindFirst(Path + Mask, Anyfile - Directory, s); { Find the first file }π If (DosError = 18) then exit; { No files to erase }π KillFile(Path + s.name); { Erase the first file }π repeatπ Findnext(s); { Find the next file }π If NOT (DOSError=18) then KillFile(Path + s.name); { Erase the file }π until Doserror=18; { no more files }π EraseFiles := IOResult; { Return the IO result }πend;π 94 05-25-9408:15ALL RODNEY JOHNSON hall of fame - my try SWAG9405 38 èo πUnit HighScr;πInterfaceπProcedure HS_Init(iNum: byte; ifn: string; icode: byte);π{Initializes the highscore manager}π{ iNum: byte - The number of scores to keep track of. Setting iNum to 0}π{ makes the program use however many scores it finds in the}π{ list file}π{ ifn: string - The filename of the list file. If the file exists, it isπ opened; otherwise, a new file is created. If iNum if set toπ more names than are in ifn, extra spaces are left blank. Ifπ ifn has too many, the extras are ignored.π NOTE: do not make inum=0 if you are creating a new listπ file}π{ icode: byte - encoding number, where 0=no encoding. The higher theπ number, the less recognizable the output file}ππFunction HS_CheckScore(score: longint): boolean;π{Checks to see if a score would make the highscore list}π{ score: longint - the score to check}π{Returns TRUE if the score made the list}ππFunction HS_NewScore(name: string; score: longint): boolean;π{Adds a new score to the list if it belongs}π{ name: string - the name of the player}π{ score: longint - the player's score}π{Returns TRUE if the score made the list}ππProcedure HS_Clear;π{Clears the highscore list, setting all names to dashes, all scores to 0}ππFunction HS_Name(i: byte): string;π{Returns the name from the Ith place of the list}π{ i: byte - the rank to check}ππFunction HS_Score(i: byte): longint;π{Returns the score from the Ith place of the list}π{ i: byte - the rank to check}ππProcedure HS_Done;π{Disposes of the highscore manager and saves the highscore list}ππImplementationπUsesπ Dos;πTypeπ PHSItem = ^THSItem;π THSItem = recordπ name: string[25];π score: longint;π end;π PHSItemList = ^THSItemList;π THSItemList = array[1..100] of THSItem;πVarπ numitems, code: byte;π item: PHSItemList;π fn: string[50];πProcedure FlipBit(var Buf; len, code: byte);πTypeπ TBuf = array[0..255] of byte;πvarπ i: byte;πbeginπ for i:=0 to len-1 doπ TBuf(Buf)[i]:=TBuf(Buf)[i] XOR Code;πend;πFunction GetStr(var f: file): string;πvarπ s: string;πbeginπ BlockRead(f, s[0], 1);π BlockRead(f, s[1], ord(s[0]));π GetStr:=s;πend;πFunction Exist(fn: string): boolean;πVarπ SRec: SearchRec;πBeginπ FindFirst(fn, $3F, SRec);π If DosError>0 then Exist:=False else Exist:=True;πEnd;πProcedure HS_Init(iNum: byte; ifn: string; icode: byte);πvarπ f: file;π i, found: byte;πbeginπ fn:=ifn;π code:=icode;π numitems:=iNum;π GetMem(item, 30*numitems);π HS_Clear;π if exist(fn) thenπ beginπ Assign(f, fn);π Reset(f, 1);π BlockRead(f, found, 1);π if numitems=0 then numitems:=found;π if found>numitems then found:=numitems;π for i:=1 to found doπ beginπ item^[i].name:=GetStr(f);π FlipBit(item^[i].name[1], ord(item^[i].name[0]), code);π BlockRead(f, item^[i].score, 4);π FlipBit(item^[i].score, 4, code);π end;π end;π if numitems=0 then numitems:=1;πend;πFunction HS_CheckScore(score: longint): boolean;πbeginπ if score>item^[numitems].score then HS_CheckScore:=TRUE else HS_CheckScore:=FALSE;πend;πFunction HS_NewScore(name: string; score: longint): boolean;πvarπ i, j: byte;π on: boolean;πbeginπ HS_NewScore:=FALSE;π for i:=1 to numitems doπ if score>item^[i].score thenπ beginπ for j:=numitems downto i+1 doπ item^[j]:=item^[j-1];π item^[i].name:=name;π item^[i].score:=score;π score:=0;π i:=numitems;π HS_NewScore:=TRUE;π end;πend;πProcedure HS_Clear;πvarπ i: byte;πbeginπ for i:=1 to numitems doπ beginπ item^[i].name:='-------------------------';π item^[i].score:=0;π end;πend;πFunction HS_Name(i: byte): string;πbeginπ HS_Name:=item^[i].name;πend;πFunction HS_Score(i: byte): longint;πbeginπ HS_Score:=item^[i].score;πend;πProcedure HS_Done;πvarπ f: file;π i: byte;πbeginπ Assign(f, fn);π Rewrite(f, 1);π BlockWrite(f, numitems, 1);π for i:=1 to numitems doπ beginπ FlipBit(item^[i].name[1], ord(item^[i].name[0]), code);π BlockWrite(f, item^[i].name, ord(item^[i].name[0])+1);π FlipBit(item^[i].score, 4, code);π BlockWrite(f, item^[i].score, 4);π end;π FreeMem(item, 30*numitems);πend;πEnd.π 95 05-25-9408:21ALL LARS P. FRIEND Registration Key Routine SWAG9405 10 èo {π* In a message originally to All, Brad Larned said:πBL >Hello All!ππBL >Does anyone have a good registration key routine, they wouldπBL >be willing toπBL >share, I can download Net-Mail or a response in this messageπBL >base will be fine..ππHere goes.... }ππtype regpass:array[1..23] of byte;ππfunction checkregister:boolean;πvarπ f:file of regpass;π p:regpass;π a,x,y,z,c:word;πbeginπ assign(f,'REGISTER.KEY');π reset(f);π read(f,p);π close(f);πππ for a:=1 to 20 doπ beginπ z:=z+p[a];π x:=x XOR p[a];π y:=y+NOT(p[a]);π end;π c:=z;π z:=z MOD 256;π x:=x MOD 256;π y:=y MOD 256;π checkregister:=false;ππ if ((x=p[21]) AND (y=p[22])) AND (z=p[23]) then checkregister:=true;π if c=0 then checkregister:=false;ππend;ππThis routine allows you to have both somebody's name and a checksum stored. πIf they don't match up, it appears that it isn't a registered copy. You can πstash whatever in the first 20 bytes, and the last three are reserved for a πchacksum. This is the routine that I use, and it seems to be pretty πmuck-proof;ππYou can write the routine to create the file and do the checksums yourself.πIt's idioticly simple. C-ya...π 96 05-26-9406:19ALL MATT SOTTILE PASCAL PASSWORD IMPORT 13 èo {πThe example that changes color and echos '*'s is nice, but does it compensateπfor delete/backspace/enter keypresses?ππThe one I posted was intended when I wrote it to be a UNIX like passwordπinput, where the cursor just sits there and doesn't react.ππDoes anyone want a simple password entry/encryption unit?ππ(I'll give it to you anyways.. ) :)ππ--CUT HERE-- }πunit crypt;π{AmoebOS v1.0 - Password/Cryyptography unit}ππ{Simple password entry and encryption routines}π{(C)1994 Matt Sottile/RAMSoft! Freeware}π{Please notify the author if you use or modify this unit in any way}π{Internet mail : matts@caeser.geog.pdx.edu or matts@psg.com}π{ ramsoft@industrial.com}ππinterfaceππfunction noecho(pmt : string) : string;πfunction pwcrypt(op : string) : string;ππimplementationππuses Crt, Dos;ππfunction noecho(pmt : string) : string;πvarπ ch : char;π d : boolean;π temp, st : string;πbeginπ write(pmt);π d := false;π temp := '';π st := '';π repeatπ temp := st;π repeat until keypressed;π ch := readkey;π if (ch = chr(8)) then st := temp;π if (ch = chr(13)) then d := true;π if not ((ch = chr(8)) and (ch = chr(13))) then st := st+ch; π until d = true;π noecho := temp;π writeln;πend;ππfunction pwcrypt(op : string) : string;πvarπ ptr : integer;π ip : string;πbeginπ ip := '';π ptr := 1;π repeatπ ip := ip+chr(((ord(op[ptr])+ord(op[length(op)-ptr]) xor length(op))));π ip[ptr] := chr(ord(ip[ptr])+2);π inc(ptr);π until ptr = length(op)+1;π pwcrypt := ip;πend;ππbeginπend.ππ 97 05-26-9406:19ALL JAMIE RUTHERFORD Scrolling or page down IMPORT 10 èo πfunction More: string;πvarπ Prompt: char;πbeginπ More:='';π if Pause and (Lines=mem[$40:$84]) thenπ beginπ write('Continue - [Y]es, [N]o? ');π Prompt:=ReadKey;π writeln(upcase(Prompt));π if Prompt in ['N','n'] thenπ halt(0)π Lines:=0π end;π inc(Lines)πend; {More}ππPause and Lines are both global variables. Since I call the functionπfrom many other functions/procedures I decided it would be less workπthen passing them through. Pause is simple a flag deciding whether orπnot you want pausing or not. You may not want to take the same action Iπdid when the user doesn't want to continue. The mem command looks atπmemory location 0040:0084 which contains the number of lines on theπscreen. This prevents the need to check what mode the screen is in.ππAnyways, the way I used it is as follows:ππwriteln(More,'What ever you may want to display');ππSince functions are executed first, it determines wheter or not toπdisplay the line or prompt to continue.ππHope that helps... (assuming you can figure out my explanations)π 98 05-26-9410:52ALL RICHARD ODOM Amortization Routine IMPORT 32 èo program amort;ππ{ This program does a good job of loan amortization. The originalπ author is unknown. I added a procedure to exit the program withoutπ showing all years for amortization. Richard Odom..VA Beach }ππconstπ MonthTab = 8; {month column}π PayTab = 14; {payment column}π PrinTab = 28; {principle column}π IntTab = 41; {interest column}π BalTab = 53; {balance column}πππvarπ balance, payment, interest, rate, years,π i1, i2, CurrInt, CurrPrin, ypay, yint, yprin,π GTPay, GTInt, GTPrin: real;π year, month, line: integer;π borrower: string[32];π response: char;πππππbeginπ repeatππ ClrScr;π write ('Name of borrower: ');π readln (borrower);π write ('Amount of loan: ');π readln (balance);π write ('Interest rate: ');π readln (interest);π i1 := interest/1200 {monthly interest};π write ('Do you know the monthly payments? ');π readln (response);ππ if UpCase(response) = 'Y'π then beginπ write ('Payment amount: ');π readln (payment);π endπ else beginπ write ('Number of years: ');π readln (years);π i2 := exp(ln(i1 + 1) * (12 * years));π payment := balance * i1 * i2 / (i2 - 1);π payment := int(payment * 100 + 0.5) / 100;π writeln ('The monthly payment is $',payment:4:2,'.')π end;ππ write ('Starting year for loan: ');π readln (year);π write ('Starting month for loan: ');π readln (month);π write ('Press <RETURN> to see monthly totals.');π readln (response);π ClrScr; line := 6;π writeln ('Loan for ',borrower);π writeln (' Loan of $',balance:4:2,' at ',interest:4:2,'% interest.');π writeln (' Fixed monthly payments of $',payment:4:2,'.');π writeln;π writeln (year:4,' Month Payment Principle Interest Balance');π ypay := 0; yprin := 0; yint := 0;π GTPay := 0; GTInt := 0; GTPrin := 0; {initialize totals}ππ while balance>0 do beginπ CurrInt := int(100 * i1 * balance +0.5) / 100;π CurrPrin := payment - CurrInt;ππ if CurrPrin>balance then beginπ CurrPrin := balance;π payment := CurrInt + CurrPrin;π end;ππ balance := balance - CurrPrin;π ypay := ypay + payment; yint := yint + CurrInt; yprin := yprin + CurrPrin;π GTPay := GTPay + payment; GTInt := GTInt + CurrInt; GTPrin := GTPrin + CurrPrin;π line := line + 1; GotoXY(MonthTab,line);π write (month:2); GotoXY(PayTab,line);π write (payment:10:2); GotoXY(PrinTab,line);π write (CurrPrin:10:2); GotoXY(IntTab,line);π write (CurrInt:10:2); GotoXY(BalTab,line);π writeln (balance:12:2);π month := month + 1;ππ if (month>12) or (balance=0.0) then beginπ writeln; line := line + 2;π write (year:4,' Total'); GotoXY(PayTab,line);π write (ypay:10:2); GotoXY(PrinTab,line);π write (yprin:10:2); GotoXY(IntTab,line);π write (yint:10:2); GotoXY(BalTab,line);π writeln (balance:12:2);π year := year + 1;π month := 1;π ypay := 0; yprin := 0; yint := 0;ππ if balance>0 then beginπ writeln;π writeln ('Press <RETURN> to see ',year:4,'.');π write('Enter Q to end program ');π readln (response);π If upcase(response)='Q' thenπ halt;π ClrScr; line := 2; writeln (year:4,' Month Payment Principle Interest Balance');π end;ππ end;ππ end; {while}ππ writeln; line := line + 2;π write ('Grand Total'); GotoXY(PayTab,line);π write (GTPay:10:2); GotoXY(PrinTab,line);π write (GTPrin:10:2); GotoXY(IntTab,line);π write (GTInt:10:2); GotoXY(BalTab,line);π writeln (balance:12:2);π writeln;π write ('Do you wish to start over? ');π readln (response);ππ until UpCase(response)='N';ππend. 99 05-26-9411:04ALL SWAG SUPPORT TEAM General Library Routines IMPORT 159 èo unit MiscLib;πinterfaceπuses crt,dos;ππconstπ MaxFiles = 30;π MaxChoices = 8;ππtypeπ STRING79 = string[79];π TOGGLE_REC = recordπ NUM_CHOICES: integer;π STRINGS : array [0..8] of STRING79;π LOCATIONS : array [0..8] of integer;π end;π RESPONSE_TYPE = (NO_RESPONSE, ARROW, KEYBOARD, RETURN);π MOVEMENT = (NONE, LEFT, RIGHT, UP, DOWN);π FnameType = string[12];π FileListType = array[1..MaxFiles] of FnameType;π ScrMenuRec = recordπ Selection : array[1..MaxChoices] of STRING79;π Descripts : array[1..MaxChoices,1..3] of STRING79;π end;π ScrMenuType = objectπ NumChoices : integer;π Last : integer;π Line, Col : integer;π MenuData : ScrMenuRec;π procedure Setup(MData: ScrMenuRec);π function GetChoice : integer;π end;πππprocedure Set_Video (ATTRIBUTE: integer);πprocedure Put_String (OUT_STRING: STRING79; LINE, COL, ATTRIB: integer);πprocedure Put_Text (OUT_STRING: STRING79; LINE, COL: integer);πprocedure Put_Colored_Text (OUT_STRING: STRING79;π LINE, COL, TXTCLR, BKGCLR: integer);πprocedure Put_Centered_String (OUT_STRING: STRING79; LINE, ATTRIB: integer);πprocedure Put_Centered_Text (OUT_STRING: STRING79; LINE: integer);πprocedure Put_Error (OUT_STRING: STRING79; LINE, COL: integer);πprocedure End_Erase (LINE, COL: integer);πprocedure Put_Prompt (OUT_STRING: STRING79; LINE, COL: integer);πprocedure Get_Response (var RESPONSE : RESPONSE_TYPE;π var DIRECTION : MOVEMENT;π var KEY_RESPONSE: char);πprocedure Get_String (var IN_STRING: STRING79;π LINE, COL, ATTRIB, STR_LENGTH: integer);πprocedure Get_Integer (var NUMBER: integer;π LINE, COL, ATTRIB, NUM_LENGTH: integer);πprocedure Get_Prompted_String (var IN_STRING: STRING79;π INATTR, STR_LENGTH: integer;π STRDESC: STRING79;π DESCLINE, DESCCOL: integer;π PROMPT: STRING79;π PRLINE, PRCOL: integer);πprocedure Put_1col_Toggle (TOGGLE: TOGGLE_REC; COL, CHOICE: integer);πprocedure Get_1col_Toggle ( TOGGLE: TOGGLE_REC;π COL: integer;π var CHOICE: integer;π PROMPT: STRING79;π PRLINE, PRCOL: integer);πprocedure Box_Text (TopX, TopY, BotX, BotY, BoxColor: integer);πprocedure Solid_Box (TopX, TopY, BotX, BotY, BoxColor: integer);πprocedure swap_fnames(var A,B: FnameType);πprocedure FileSort(var fname: FileListType; NumFiles: integer);πfunction Get_Files_Toggle (choices: FileListType;π NumChoices,NumRows,row,col:integer): FnameType;πfunction Get_File_Menu(mask: string;NumRows,Row,Col: integer): FnameType;πππ{-------------------------------------------------------------------------}πimplementationππprocedure Set_Video (ATTRIBUTE: integer);π{πNOTES:π The attribute code, based on bits, is as follows:π 0 - normal video 1 - reverse videoπ 2 - bold video 3 - reverse and boldπ 4 - blinking video 5 - reverse and blinkingπ 6 - bold and blinking 7 - reverse, bold, and blinkingπ}ππvarπ BLINKING,π BOLD: integer;ππbeginπ BLINKING := (ATTRIBUTE AND 4)*4;π if (ATTRIBUTE AND 1) = 1 thenπ beginπ BOLD := (ATTRIBUTE AND 2)*7;π Textcolor (1 + BLINKING + BOLD);π TextBackground (3);π endπ elseπ beginπ BOLD := (ATTRIBUTE AND 2)*5 DIV 2;π Textcolor (7 + BLINKING + BOLD);π TextBackground (0);π end;πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_String (OUT_STRING: STRING79;π LINE, COL, ATTRIB: integer);ππbeginπ Set_Video (ATTRIB);π GotoXY (COL, LINE);π write (OUT_STRING);π Set_Video (0);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Text (OUT_STRING: STRING79;π LINE, COL: integer);ππbeginπ GotoXY (COL, LINE);π write (OUT_STRING);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Colored_Text (OUT_STRING: STRING79;π LINE, COL, TXTCLR, BKGCLR: integer);ππbeginπ GotoXY (COL, LINE);π TextColor (TXTCLR);π TextBackground (BKGCLR);π write (OUT_STRING);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Centered_String (OUT_STRING: STRING79;π LINE, ATTRIB: integer);ππbeginπ Put_String (OUT_STRING, LINE, 40-Length(OUT_STRING) div 2, ATTRIB);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Centered_Text (OUT_STRING: STRING79;π LINE: integer);ππbeginπ Put_Text (OUT_STRING, LINE, 40-Length(OUT_STRING) div 2);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Error (OUT_STRING: STRING79;π LINE, COL: integer);ππvarπ ANY_CHAR : char;ππbeginπrepeatπ Put_String (OUT_STRING, LINE, COL, 6);πuntil keypressed = true;πend;ππ{-------------------------------------------------------------------------}ππprocedure End_Erase (LINE, COL: integer);ππbeginπ GotoXY (COL, LINE);π ClrEol;πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_Prompt (OUT_STRING: STRING79;π LINE, COL: integer);ππbeginπ GotoXY (COL, LINE);π ClrEol;π Put_String (OUT_STRING, LINE, COL, 3);πend;ππ{-------------------------------------------------------------------------}πππprocedure Get_Response (var RESPONSE : RESPONSE_TYPE;π var DIRECTION : MOVEMENT;π var KEY_RESPONSE: char);ππconstπ BELL = 7;π CARRIAGE_RETURN = 13;π ESCAPE = 27;π RIGHT_ARROW = 77;π LEFT_ARROW = 75;π DOWN_ARROW = 80;π UP_ARROW = 72;ππvarπ IN_CHAR: char;ππbeginπ RESPONSE := NO_RESPONSE;π DIRECTION := NONE;π KEY_RESPONSE := ' ';π repeatπ IN_CHAR := ReadKey;π if IN_CHAR = #0 thenπ beginπ RESPONSE := ARROW;π IN_CHAR := ReadKey;π if Ord(IN_CHAR) = LEFT_ARROW thenπ DIRECTION := LEFTπ else if Ord(IN_CHAR) = RIGHT_ARROW thenπ DIRECTION := RIGHTπ else if Ord(IN_CHAR) = DOWN_ARROW thenπ DIRECTION := DOWNπ else if Ord(IN_CHAR) = UP_ARROW thenπ DIRECTION := UPπ elseπ beginπ RESPONSE := NO_RESPONSE;π write (Chr(BELL));π endπ endπ else if Ord(IN_CHAR) = CARRIAGE_RETURN thenπ RESPONSE := RETURNπ elseπ beginπ RESPONSE := KEYBOARD;π KEY_RESPONSE := UpCase (IN_CHAR);π end;π until RESPONSE <> NO_RESPONSE;πend;ππ{-------------------------------------------------------------------------}ππprocedure Get_String (var IN_STRING: STRING79;π LINE, COL, ATTRIB, STR_LENGTH: integer);ππvarπ OLDSTR : STRING79;π IN_CHAR: char;π I : integer;ππconstπ BELL = 7;π BACK_SPACE = 8;π CARRIAGE_RETURN = 13;π ESCAPE = 27;π RIGHT_ARROW = 77;ππbeginπ OLDSTR := IN_STRING;π Put_String (IN_STRING, LINE, COL, ATTRIB);π for I := Length(IN_STRING) to STR_LENGTH-1 doπ Put_String (' ', LINE, COL + I, ATTRIB);π GotoXY (COL, LINE);π IN_CHAR := ReadKey;π if Ord(IN_CHAR) <> CARRIAGE_RETURN thenπ IN_STRING := '';π while Ord(IN_CHAR) <> CARRIAGE_RETURN doπ beginπ if Ord(IN_CHAR) = BACK_SPACE thenπ beginπ if Length(IN_STRING) > 0 thenπ beginπ IN_STRING[0] := Chr(Length(IN_STRING)-1);π write (Chr(BACK_SPACE));π write (' ');π write (Chr(BACK_SPACE));π end;π end { if BACK_SPACE }π else if IN_CHAR = #0 thenπ beginπ IN_CHAR := ReadKey;π if Ord(IN_CHAR) = RIGHT_ARROW thenπ beginπ if Length(OLDSTR) > Length(IN_STRING) thenπ beginπ IN_STRING[0] := Chr(Length(IN_STRING) + 1);π IN_CHAR := OLDSTR[Ord(IN_STRING[0])];π IN_STRING[Ord(IN_STRING[0])] := IN_CHAR;π write (IN_CHAR);π endπ end { RIGHT_ARROW }π elseπ write (Chr(BELL));π end { IN_CHAR = #0 }π else if Length (IN_STRING) < STR_LENGTH thenπ beginπ IN_STRING[0] := Chr(Length(IN_STRING) + 1);π IN_STRING[Ord(IN_STRING[0])] := IN_CHAR;π TextColor (15);π TextBackGround (11);π write (IN_CHAR);π endπ elseπ write (Chr(BELL));π IN_CHAR := ReadKey;π end;π Put_String (IN_STRING, LINE, COL, ATTRIB);π for I := Length(IN_STRING) to STR_LENGTH - 1 doπ Put_String (' ', LINE, COL+I, ATTRIB);πend;ππ{-------------------------------------------------------------------------}ππprocedure Get_Integer (var NUMBER: integer;π LINE, COL, ATTRIB, NUM_LENGTH: integer);ππconstπ BELL = 7;ππvarπ VALCODE : integer;π ORIGINAL_STR,π TEMP_STR : STRING79;π TEMP_INT : integer;ππbeginπ Str (NUMBER:NUM_LENGTH, ORIGINAL_STR);π repeatπ TEMP_STR := ORIGINAL_STR;π Get_String (TEMP_STR, LINE, COL, ATTRIB, NUM_LENGTH);π while TEMP_STR[1] = ' ' doπ TEMP_STR := Copy (TEMP_STR, 2, Length (TEMP_STR));π Val (TEMP_STR, TEMP_INT, VALCODE);π if (VALCODE <> 0) thenπ write (Chr(BELL));π until VALCODE = 0;π NUMBER := TEMP_INT;π Str (NUMBER:NUM_LENGTH, TEMP_STR);π Put_String (TEMP_STR, LINE, COL, ATTRIB);πend;ππ{-------------------------------------------------------------------------}ππprocedure Get_Prompted_String (var IN_STRING: STRING79;π INATTR, STR_LENGTH: integer;π STRDESC: STRING79;π DESCLINE, DESCCOL: integer;π PROMPT: STRING79;π PRLINE, PRCOL: integer);ππbeginπ Put_String (STRDESC, DESCLINE, DESCCOL, 2);π Put_Prompt (PROMPT, PRLINE, PRCOL);π Get_String (IN_STRING, DESCLINE, DESCCOL + Length(STRDESC),π INATTR, STR_LENGTH);π Put_String (STRDESC, DESCLINE, DESCCOL, 0);πend;ππ{-------------------------------------------------------------------------}ππprocedure Put_1col_Toggle (TOGGLE: TOGGLE_REC;π COL, CHOICE: integer);ππvarπ I: integer;ππbeginπ with TOGGLE doπ beginπ Put_String (STRINGS[0], LOCATIONS[0], COL, 0);π for I := 1 to NUM_CHOICES doπ Put_String (STRINGS[I], LOCATIONS[I], COL, 0);π if (CHOICE <1) or (CHOICE > NUM_CHOICES) thenπ CHOICE := 1;π Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);π end;πend;ππ{-------------------------------------------------------------------------}ππprocedure Get_1col_Toggle ( TOGGLE: TOGGLE_REC;π COL: integer;π var CHOICE: integer;π PROMPT: STRING79;π PRLINE, PRCOL: integer);ππvarπ RESP : RESPONSE_TYPE;π DIR : MOVEMENT;π KEYCH: char;ππbeginπ Put_Colored_Text (PROMPT, PRLINE, PRCOL, 15, 0);π with TOGGLE doπ beginπ Put_String (STRINGS[0], LOCATIONS[0], COL, 2);π if (CHOICE < 1) or (CHOICE > NUM_CHOICES) thenπ CHOICE := 1;π Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);π RESP := NO_RESPONSE;π while RESP <> RETURN doπ beginπ Get_Response (RESP, DIR, KEYCH);π case RESP ofπ ARROW:π if DIR = UP thenπ beginπ Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 0);π if CHOICE = 1 thenπ CHOICE := NUM_CHOICESπ elseπ CHOICE := CHOICE - 1;π Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);π endπ else if DIR = DOWN thenπ beginπ Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 0);π if CHOICE = NUM_CHOICES thenπ CHOICE := 1π elseπ CHOICE := CHOICE + 1;π Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);π endπ elseπ write (Chr(7));π KEYBOARD: write (Chr(7));π RETURN: ;π end;π end; {while}π Put_String (STRINGS[0], LOCATIONS[0], COL, 0);π end;πend;ππ{-------------------------------------------------------------------------}ππprocedure Box_Text (TopX, TopY, BotX, BotY, BoxColor: integer);ππvarπ i : integer;π width : integer;π height: integer;ππbeginπ TextBackGround (BoxColor);π height := BotY - TopY;π width := BotX - TopX;π GotoXY (TopX, TopY);π for i := 1 to width doπ write (' ');π for i := TopY to (TopY+height) doπ beginπ GotoXY (TopX, i);π write (' ');π GotoXY (BotX-1, i);π write (' ');π end;π GotoXY (TopX, BotY);π for i := 1 to width doπ write (' ');πend;ππ{-------------------------------------------------------------------------}ππprocedure Solid_Box (TopX, TopY, BotX, BotY, BoxColor: integer);ππvarπ i : integer;π j : integer;π width : integer;ππbeginπ TextBackGround (BoxColor);π GotoXY (TopX, TopY);π width := BotX - TopX;π for i := TopY to BotY doπ beginπ for j := 1 to width doπ write (' ');π GotoXY (TopX, i);π end;πend;ππprocedure swap_fnames(var A,B: FnameType);πvarπ Temp : FnameType;πbeginπ Temp := A;π A := B;π B := Temp;πend;ππprocedure FileSort(var fname: FileListType;NumFiles: integer);πvarπ i,j : integer;πbeginπ for j := NumFiles downto 2 doπ for i := 1 to j-1 doπ if fname[i]>fname[j] thenπ swap_fnames(fname[i],fname[j]);πend;ππfunction Get_Files_Toggle (choices:FileListType;π NumChoices,NumRows,row,col:integer): FnameType;πvarπ i,r : integer;π Resp : Response_Type;π dir : movement;π keych : char;ππprocedure Put_Files_Toggle (choices: FileListType; First,NumRows,row,col: integer);πvarπ i : integer;πbeginπ for i := 0 to NumRows-1 doπ Put_string (choices[First+i],row+i,col,0);πend;ππprocedure Padnames;πvarπ i,p : integer;πbeginπ for i := 1 to MaxFiles doπ beginπ p := 12-length(choices[i]);π while p>0 doπ beginπ choices[i] := choices[i]+' ';π p := p-1;π end;π end;πend;ππbeginπ Padnames;π i := 1;π r := 1;π if NumChoices < NumRows thenπ NumRows := NumChoices;π Put_Files_Toggle (choices,1,NumRows,row,col);π Get_Files_Toggle := choices[i];π Put_string(choices[i],row,col,1);π resp := No_Response;π while resp <> Return doπ beginπ Get_response (resp,dir,keych);π case resp ofπ ARROW: if dir=UP thenπ beginπ Put_string(choices[i],row+r-1,col,0);π if i=1 thenπ beginπ i := NumChoices;π r := NumRows;π Put_Files_Toggle(choices,i+1-NumRows,NumRows,row,col);π endπ else if r=1 thenπ beginπ i := i-1;π Put_Files_Toggle(choices,i,NumRows,row,col);π endπ elseπ beginπ i := i-1;π r := r-1;π end;π Put_string(choices[i],row+r-1,col,1);π endπ else if dir=DOWN thenπ beginπ Put_string(choices[i],row+r-1,col,0);π if i=NumChoices thenπ beginπ i := 1;π r := 1;π Put_Files_Toggle(choices,i,NumRows,row,col);π endπ else if r=NumRows thenπ beginπ i := i+1;π Put_Files_Toggle(choices,i+1-NumRows,NumRows,row,col);π endπ elseπ beginπ i := i+1;π r := r+1;π end;π Put_string(choices[i],row+r-1,col,1);π endπ elseπ write (chr(7));π KEYBOARD: write (chr(7));π end; { case }π end;π Get_Files_toggle := choices[i];πend;ππfunction Get_File_Menu(mask: string;NumRows,Row,Col: integer): FnameType;πvarπ i : integer;π NumFiles : integer;π FileList : FileListType;π dirinfo : SearchRec;πbeginπ i := 1;π FindFirst(mask,Archive,dirinfo);π while (DosError=0) AND (i<MaxFiles+1) doπ beginπ FileList[i] := dirinfo.name;π FindNext(dirinfo);π i := i+1;π end;π NumFiles := i-1;π FileSort(FileList,NumFiles);π Get_File_Menu := Get_Files_Toggle(FileList,NumFiles,NumRows,Row,Col);πend;ππprocedure ScrMenuType.Setup(MData : ScrMenuRec);πvar i : integer;πbeginπ with MenuData doπ for i := 1 to MaxChoices doπ beginπ selection[i] := MData.selection[i];π Descripts[i,1] := MData.descripts[i,1];π Descripts[i,2] := MData.descripts[i,2];π Descripts[i,3] := MData.descripts[i,3];π end;πend;ππfunction ScrMenuType.GetChoice : integer;πvarπ i : integer;π Resp : Response_Type;π Dir : Movement;π KeyCh : char;ππprocedure PutDescripts;πvar i : integer;πbeginπ window(0,0,79,24);π Solid_Box(3,21,79,24,lightgray);π for i := 1 to 3 doπ Put_Colored_Text(MenuData.Descripts[last,i],20+i,4,white,lightgray);πend;ππbeginπwith MenuData doπbeginπ for i := 0 to NumChoices-1 doπ Put_String(Selection[i+1],Line+i,Col,0);π Put_String(Selection[Last],Line+Last-1,Col,1);π Resp := No_Response;π while Resp <> Return doπ beginπ PutDescripts;π Get_Response(Resp,Dir,KeyCh);π case Resp ofπ Arrow :π if Dir = Up thenπ beginπ Put_String(Selection[Last],Line+Last-1,Col,0);π if Last = 1 thenπ Last := NumChoicesπ elseπ Last := Last-1;π Put_String(Selection[Last],Line+Last-1,Col,1);π endπ else if Dir = Down thenπ beginπ Put_String(Selection[Last],Line+Last-1,Col,0);π if Last = NumChoices thenπ Last := 1π elseπ Last := Last+1;π Put_String(Selection[Last],Line+Last-1,Col,1);π end;π end;π end;πend;πend;π{ Initialization Area }πbeginπend.ππ{------------------------------------ TEST PROGRAM ------------------- }ππprogram testdir;π{ program attempts to read directory }π{ shows filenames as column }ππuses dos,crt,miscLib;ππvarπ Fchoice : FnameType;π i,n : integer;ππππ{ *************** MAIN PROGRAM *************** }ππbeginπ ClrScr;π Fchoice := Get_File_Menu('*.*',8,10,30);π Put_string(Fchoice,24,1,0);π ReadLn;πend.πππ{------------------------------------ TEST PROGRAM ------------------- }ππprogram TestMenu;πuses crt,MiscLib;ππconstπ ChoiceData : ScrMenuRec =π (selection : ('Choice 1','Choice 2','Choice 3','Choice 4','','','','');π Descripts : (('This is','No 1','The First Choice'),π ('Number 2','The Second Choice and default',''),π ('Number 3','Last Choice, for now...','Last Line'),π ('Number 4','An added Selection','How bout that?'),π ('','',''),π ('','',''),π ('','',''),π ('','','')));πvarπ ScrMenu : ScrMenuType;π Choice : integer;ππbeginπ TextColor(white);π TextBackGround(Blue);π ClrScr;π ScrMenu.NumChoices := 4;π ScrMenu.Last := 2;π ScrMenu.Line := 6;π ScrMenu.Col := 30;π ScrMenu.Setup(ChoiceData);π Choice := ScrMenu.GetChoice;π ReadLn;πend.
