NNNNNNԤp NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNONNNNNNNNNNNNNNNNNNNNNN N@`  @! #@%`')+-135`9;?A OE`GIKMOQSU`WY[]_/c@e`gikmoq s@uw}@` @  @ ` / @ ` @ ` ǀ ɠ @ o ׀ ٠  @` O`!Aa  !Aa!!#A%')+-/1!3A5a79;=?ACAEaKMOQ!SAUaWY@`  @! #@%`')+-135`9;?A OE`GIKMOQSU`WY[]_/c@e`gikmoq s@uw}@` @  @ ` / @ ` @ ` ǀ ɠ @ o ׀ ٠  @` O`!Aa  !Aa!!#A%')+-/1!3A5a79;=?ACAEaKMOQ!SAUaWYPASCAL 001AESVDI DOCTt /CHAR DOCXt CMPBIN PAS[t CONVERT2PAS`t CONVERT2PRGct :COPY PASft / COPY2 DOCit 2COPY2 PASkt 4 COPY2 PRGmt 7DATETI PASqt =DGEN PAStt CDGEN TOSwt HDIRLIS PASzt PDSEEK PAS}t RDSEEK PRGt TDUMP PASt X EXAMPL PASt \EXPERT DOCt a(FILE DOCt l%GEMBOX PASt v INSERT MODt yHINSERT PASt {INSERT TABt INSERT TOSt INTRO DOCt ISTRVA PASt MADLIB PASt MORGAGE PASt #MORGAGE PRGt DMOUNTN PASt !ONEDRV DOCt PASACC DOCt +PEEKPK INCt PEEKPK O t PEEKPK S t PFIX1 PASt PFORMA PASt vPORT DOCt SCRDMP PASt SCRNDU 10Xt $SCRNDU PASt SCRSAV ACCt  SELECT MODt SELECT PASt SELECT TAB t SELECT TOSt &SHELL2 PASt &WSORTDRIVPAS"t < SORTDRIVPRG't B2SORT_DAT +t GSORT_TAB /t HTIME DOC2t I TSIZE PAS6t LTYPRIT PAS:t P*ISKTOP INFt [ MAKING GENERIC AES AND VDI CALLS FROM PERSONAL PASCAL ----------------------------------------------------- As some of you have discovered, because of prior experience with the Atari ST developer's package, there are a number of calls within the GEM system (AES and VDI) which are not yet supported by Personal Pascal. Luckily, within the PASGEM library there are two routines which already support additional calls to GEM. This document gives you the information you need in order to call these two generic GEM routines. AES CALLS --------- First of all, we are going to tackle AES calls. In the process of explaining how to call the generalized AES routine, we will be implementing a new call which is not supported by Pascal. This routine, which is called "graf_mkstate" in the C bindings, returns the current state of the mouse buttons and the key- board modifier keys (i.e., alternate, left and right shift keys, and control). This routine takes four parameters which are the addresses of four two-byte variables in which to put the mouse and keyboard state information. Since passing an address in Pascal is equivalent to passing a variable as a VAR parameter, the declaration of the routine we're going to construct is going to start like this: (* Mouse_Key_State - Return the current mouse position and the state of both the mouse buttons and the keyboard modifier keys. *) PROCEDURE Mouse_Key_State( VAR x, y, buttons, keys : integer ) ; Before we start filling in the rest of the procedure, we have to look at how parameters are passed to the AES. There are four separate areas in which values are passed to and returned from AES. The first area is the "global parameter area", where AES stores various parameters it needs to keep around between calls. Since the application program should not modify these values, there is no way to access the "global" array from Pascal. The second area is the "integer input array", in which various integer values may be passed to AES. Similarly, there is an "integer output array" in which AES passes values back to the calling program. The fourth and fifth arrays are the "address input array" and the "address output array". These two areas will contain address parameters passed to or from AES. The Pascal library keeps track of the global parameter area, since it must remain intact, but the other arrays must be declared in your GEM program if you want to make calls to the AES handler. In order to declare the arrays easily, we will set up their types first: TYPE Pointer = ^char ; (* Just a filler declaration! *) Int_In_Parms = ARRAY [ 0..15 ] OF integer ; Int_Out_Parms = ARRAY [ 0..45 ] OF integer ; Addr_In_Parms = ARRAY [ 0..1 ] OF Pointer ; Addr_Out_Parms = ARRAY [ 0..0 ] OF Pointer ; The declaration of "Pointer" is just used to emphasize that the address in and out parameters are ADDRESSES, and not just numeric values. Notice that the integer arrays only have lengths 16 and 46, respectively. This is sufficient for most calls, but if you want to make a call to VDI (see below) which needs more slots in these arrays, increase the size accordingly. Now that we know the TYPEs of the local variables we need, we can declare them: VAR int_in : Int_In_Parms ; int_out : Int_Out_Parms ; addr_in : Addr_In_Parms ; addr_out : Addr_Out_Parms ; OK, we're ready to look into the actual routine which we will be calling to interface to GEM. It takes five parameters. The first is the AES call number, which is 79 for out "graf_mkstate" call. The next four parameters are just the arrays which we just declared, passed as VAR parameters. The routine should be declared EXTERNAL as follows: PROCEDURE AES_Call( op : integer ; VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ; VAR addr_in : Addr_In_Parms ; VAR addr_out : Addr_Out_Parms ) ; EXTERNAL ; Now that we know all of our variables and parameters, and everything the AES_Call routine is expecting, we can look at what we need to do to actually perform the GEM call. According to the AES documentation, the "graf_mkstate" call doesn't expect any parameters, and it returns the results in the "integer output array" as follows: int_out[0] -- error code (0 if no error occurred) int_out[1] -- current mouse x position int_out[2] -- mouse y position int_out[3] -- mouse button state int_out[4] -- keyboard modifier state We should never get an error with this call, since no parameters are passed in, so we're going to ignore the error code. This isn't a good idea in general, but it simplifies our presentation somewhat. The complete code required to perform the call and return the result values in the proper parameters is as follows: BEGIN AES_Call( 79, int_in, int_out, addr_in, addr_out ) ; x := int_out[1] ; y := int_out[2] ; buttons := int_out[3] ; keys := int_out[4] ; END ; To summarize this section on making AES calls, here is a complete listing of the Mouse_Key_State routine, without the intervening text: (* Mouse_Key_State - Return the current mouse position and the state of both the mouse buttons and the keyboard modifier keys. *) PROCEDURE Mouse_Key_State( VAR x, y, buttons, keys : integer ) ; TYPE Pointer = ^char ; (* Just a filler declaration! *) Int_In_Parms = ARRAY [ 0..15 ] OF integer ; Int_Out_Parms = ARRAY [ 0..45 ] OF integer ; Addr_In_Parms = ARRAY [ 0..1 ] OF Pointer ; Addr_Out_Parms = ARRAY [ 0..0 ] OF Pointer ; VAR int_in : Int_In_Parms ; int_out : Int_Out_Parms ; addr_in : Addr_In_Parms ; addr_out : Addr_Out_Parms ; PROCEDURE AES_Call( op : integer ; VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ; VAR addr_in : Addr_In_Parms ; VAR addr_out : Addr_Out_Parms ) ; EXTERNAL ; BEGIN AES_Call( 79, int_in, int_out, addr_in, addr_out ) ; x := int_out[1] ; y := int_out[2] ; buttons := int_out[3] ; keys := int_out[4] ; END ; VDI CALLS --------- Accessing the VDI system is very similar to the discussion of AES calls above. The only main difference is that, although there is a "global parameter array", it doesn't need to stay intact. Also, sometimes you need to get return values in this array. Also, no address parameters are ever passed, but a new type of value is passed and returned, points. So the TYPE declarations for the various arrays we need are slightly different: TYPE Ctrl_Parms = ARRAY [ 0..11 ] OF integer ; Int_In_Parms = ARRAY [ 0..15 ] OF integer ; Int_Out_Parms = ARRAY [ 0..45 ] OF integer ; Pts_In_Parms = ARRAY [ 0..11 ] OF integer ; Pts_Out_Parms = ARRAY [ 0..11 ] OF integer ; For our VDI calling example, we're going to implement the call which allows you to control the height of text that is drawn using the "Draw_String" call. This call is known in the VDI documentation as "vst_height", but we're going to declare it like this: (* Text_Height - Set the height in pixels of text, when it is drawn using the Draw_String library call. *) PROCEDURE Text_Height( height : integer ) ; Again, we need to declare the variables which we are going to pass to VDI: VAR control : Ctrl_Parms ; int_in : Int_In_Parms ; int_out : Int_Out_Parms ; pts_in : Pts_In_Parms ; pts_out : Pts_Out_Parms ; The actual generic routine we are going to call to perform VDI operations is very similar to the AES_Call routine described above. One difference is that we pass two command numbers instead of one. The second number is only used when we call the GSX graphics primitives; it is the GSX primitive number which we want to use. For all non-GSX calls (i.e., most of the time), this second number will be zero (as it is in this case). Also, there is one additional parameter, called "translate" in the declaration below, which specifies whether to translate the points in the "pts_in" and "pts_out" array RELATIVE to the current origin. What this means is that if you use the Set_Window call to make a window current, all points passed to or from VDI will be translated to screen coordinates such that (0,0) is equivalent to the upper left of that window, PROVIDED the value of "translate" is true. If you don't want such translation to occur (we don't, in this case, since the "point" we are passing is actually the height we want!), pass in "false" for this parameter. The declaration of the generic VDI call is as follows: PROCEDURE VDI_Call( cmd, sub_cmd : integer ; nints, npts : integer ; VAR ctrl : Ctrl_Parms ; VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ; VAR pts_in : Pts_In_Parms ; VAR pts_out : Pts_Out_Parms ; translate : boolean ) ; EXTERNAL ; Notice that we must tell VDI the number of integers and points which we are passing. The particular call we want to use is number 12, "set character height, absolute mode". It expects two parameters, as follows: pts_in[0] -- 0 (the value zero) pts_in[1] -- desired height in pixels It returns several parameters: pts_out[0] -- character width selected pts_out[1] -- character height selected pts_out[2] -- character cell width selected pts_out[3] -- character cell height selected Why are there four return values instead of two? The first two (0 and 1) are usually SMALLER than the other two, for the following reason. The "character height" (not cell height) is measured from the baseline (the bottom of capital letters) to the top line (the top of capitals, including a little space). The character width is, similarly, measured from the left edge to the right edge of characters. The "cell width" and "cell height", on the other hand, are measured from the very bottom to the very top and the very left to the very right of the "cell" in which a character is drawn. Since some space is put on all sides of a character, the "cell" measurements are a little larger than the other measurements. We're actually going to ignore all of the return parameters, since we just want to set the values and assume they are correct. The main body of our PROCEDURE is, then: BEGIN pts_in[0] := 0 ; pts_in[1] := height ; VDI_Call( 12, 0, 0, 2, control, int_in, int_out, pts_in, pts_out, false ) ; END ; In order to look at the routine as a whole, here are all the neccessary declarations and code together, without the intervening text: (* Text_Height - Set the height in pixels of text, when it is drawn using the Draw_String library call. *) PROCEDURE Text_Height( height : integer ) ; TYPE Ctrl_Parms = ARRAY [ 0..11 ] OF integer ; Int_In_Parms = ARRAY [ 0..15 ] OF integer ; Int_Out_Parms = ARRAY [ 0..45 ] OF integer ; Pts_In_Parms = ARRAY [ 0..11 ] OF integer ; Pts_Out_Parms = ARRAY [ 0..11 ] OF integer ; VAR control : Ctrl_Parms ; int_in : Int_In_Parms ; int_out : Int_Out_Parms ; pts_in : Pts_In_Parms ; pts_out : Pts_Out_Parms ; PROCEDURE VDI_Call( cmd, sub_cmd : integer ; nints, npts : integer ; VAR ctrl : Ctrl_Parms ; VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ; VAR pts_in : Pts_In_Parms ; VAR pts_out : Pts_Out_Parms ; translate : boolean ) ; EXTERNAL ; BEGIN pts_in[0] := 0 ; pts_in[1] := height ; VDI_Call(12, 0, 0, 2, control, int_in, int_out, pts_in, pts_out, false); END ;  Character I/O Page 1 Character Input and Output The ST supports five character oriented devices. Of these five, you will probably only use four, the printer port, the RS232 port, the MIDI port, and the keyboard/console. The other device is the internal data path to the intelligent keyboard unit (which handles the mouse and joysticks, as well as the keyboard); you will seldom, if ever, need to access that device directly! One of the most common operations on character oriented devices is reading a single character. The following few routines perform that function: Read character from standard input. FUNCTION conin : Long_Integer ; GEMDOS( 1 ) ; This call waits for a character to be typed from the standard input device (normally the keyboard), echoes it to the standard output (normally the screen), and returns the character thus read in the same manner as the bconin BIOS call. This call should only be used from a TOS application. You can also get a character from the standard input by Reading characters from the standard file Input, which is equivalent to using this routine. In fact, unless you have a real need to use the routines described here, it is usually better to use built-in Pascal methods. Get a character from the auxilliary (RS232) device. FUNCTION auxin : Integer ; GEMDOS( 3 ) ; If you want characters from the RS232 device, use this routine. Since the characters returned by this call are only 8 bits, the return value is only an Integer. Get character from character-oriented device. This next routine is the underlying BIOS call which can be used to perform input from any of the five devices. You should normally use one of the above GEMDOS calls whenever possible, but if you need to get input from the MIDI port, for example, you will need this routine: FUNCTION bconin( device : Integer ) : Long_Integer ; BIOS( 2 ) ; This function returns a character from the specified character-oriented device. The valid values for the device parameter are as follows: 0 printer port (not used for input) 1 RS232 port 2 keyboard 3 MIDI port 4 intelligent keyboard (don't use!) If no character was waiting when bconin was called, it waits until a character is available. If you don't want to wait for characters, you should call bconstat first, to determine that a character is available. The bconin function returns the character value in the low byte of the returned Character I/O Page 2 Long_Integer. If the specified device is the console (device 2), however, the return value is more complex. In that case, the keyboard scancode is returned in the upper word, and the ASCII equivalent (if any) is returned in the lower word. If you only want the Integer return value, and you want to assign it to an Integer variable, remember that you must use the built-in function Int to convert from a Long_Integer to an Integer. You may wish to find out whether a character is available before calling one of the character input routines. Just as we saw above, there are several calls designed to get that status: Get status of standard input. Don't use this one!!! FUNCTION c_conis : boolean ; GEMDOS( 11 ) ; This routine is supposed to return True if at least one character is available on the standard input device (normally the keyboard). If the keyboard buffer ever gets full, however, this routine ceases to work properly, always returning True. For this reason, we recommend you use the bconstat BIOS call, instead. Get status of auxilliary (RS232) port. FUNCTION auxstat : Boolean ; GEMDOS( 18 ) ; This call returns True, if at least one character is ready for input from the RS232 port, and False, otherwise. If you need to get the input status of the MIDI port or the keyboard (because of the bug in constat, above), you will have to use the following routine which is the underlying BIOS call: Character-oriented device input status FUNCTION bconstat( device : Integer ) : Boolean ; BIOS( 1 ) ; This function expects the number of a character oriented device, as described above (0-4). It returns a True value if at least one character is waiting for input and False otherwise. If the device is the printer, however, there is one situation where the returned status will not be correct. You might want to define your own special-purpose status routine as follows, so you don't have to insert the device except in one place: (* Return True, if there is a keyboard character waiting. *) FUNCTION Char_Waiting : Boolean ; CONST keyboard = 2 ; (* Device number of the keyboard. *) Character I/O Page 3 FUNCTION bconstat( device : Integer ) : Boolean ; BIOS( 1 ) ; BEGIN Char_Waiting := bconstat( keyboard ) ; END ; Besides character input and input status, you also need to be able to put characters to character devices. The following routines allow those actions: Write a character to the standard output. PROCEDURE conout( c : Integer ) ; GEMDOS( 2 ) ; This call puts a character to the standard output device (normally the screen). The effect is identical to Writeing characters to the standard file Output. You should only use this call from a TOS application. Put character to character-oriented device. PROCEDURE bconout( device, c : integer ) ; BIOS( 3 ) ; This routine writes a single character to the specified device. If the device's output buffer is full, the routine will wait until the character is actually placed in the buffer. If you don't want to wait for output, you should call bcostat first, to determine that the device is ready to receive the next character. Character-oriented device output status. FUNCTION bcostat( device : Integer ) : Boolean ; BIOS( 8 ) ; This routine checks to see whether the specified device is ready to accept another character. It returns True, if the device is ready to receive, and False otherwise. If the ST is powered up while the printer is off-line, the hardware does not detect the off-line condition. The bcostat call will return True, in this case, even though the printer is not ready to accept data. As soon as the printer is turned on-line again, the status is correct. Get status of standard print device. FUNCTION c_prnos : Boolean ; GEMDOS( 17 ) ; This call returns True if the printer is available to accept characters, False otherwise. However, as mentioned in the section about the bcostat BIOS call, the ST hardware cannot detect an off-line condition if the ST is powered up while the printer is off-line. In this situation, the c_prnos function will erroneously return True. Character I/O Page 4 Check output status of auxilliary device (RS232). FUNCTION c_auxos : Boolean ; GEMDOS( 19 ) ; This routine returns True, if the standard auxilliary device (normally the RS232 port) is ready to accept data, and False, otherwise. If the auxilliary device is the RS232 port, this call will only return False if the RTS/CTS flow control method is used, and CTS goes to a false condition. { compare - Binary file comparison program. This program is just a demon- stration of file access in Personal Pascal. In the current version, single byte access to a file is not that fast, so to increase the speed of this program, you might replace the single-byte accesses with block-oriented GEMDOS reads into a buffer. The algorithm for comparison is very simple; keep track of the current offset position within the two files, get a pair of bytes to compare, and print any that don't match. If one file is shorter than the other, report that fact, too. Since we are just showing binary file access here, there is no GEM interface (if we were selling the program, you can bet there would be!). } PROGRAM Compare ; CONST max_fn = 80 ; { Maximum length of a TOS file name } TYPE file_name = STRING [ max_fn ] ; { A string big enough to hold a name } byte_file = PACKED FILE OF byte ; { The declaration for a binary file } VAR f1, f2 : byte_file ; { The buffer variables for the two files we } { will be accessing. } name1, name2 : file_name ; { And their names } { compare_files - This routine does the actual byte-for-byte compare, assuming that the two file buffer variable parameters have already been opened to the two files to compare. } PROCEDURE compare_files( VAR f1, f2 : byte_file ) ; VAR c1, c2 : byte ; { These will hold a pair of bytes to compare } offset : long_integer ; { Current offset within the two files } errors : boolean ; { True if non-matching bytes have been found } BEGIN offset := 0 ; { We start at the beginning with no errors } errors := false ; { While we aren't at the end of either file, get a pair of bytes and compare them. If they are not equal, print out the current offset, and the two values. Also set the 'errors' flag to true, so we will say at the end that the files don't match. } WHILE NOT eof(f1) AND NOT eof(f2) DO BEGIN c1 := f1^ ; get( f1 ) ; c2 := f2^ ; get( f2 ) ; IF c1 <> c2 THEN BEGIN errors := true ; writeln( offset:6:h, ': ', c1:2:h, ' ', c2:2:h ) ; END ; offset := offset + 1 ; END ; { If we reached the end of one file, but not the other, tell the user which file is shorter. } IF eof(f1) AND NOT eof(f2) THEN writeln( 'File 1 is shorter' ) ELSE IF eof(f2) AND NOT eof(f1) THEN writeln( 'File 2 is shorter' ) { If neither is shorter, and we never got a non-matching pair, tell the user the files are the same. } ELSE IF NOT errors THEN writeln( 'Files compare exactly' ) ; END ; { main routine - Ask the user for the names of the two files to compare, open the files, and call 'compare_files' to do the real work. We are not getting the parameters from a command line so the program can be called from the desktop or the Pascal manager. Those of you using command-line interfaces might want to pull the parameters from the command line, instead. } BEGIN write( 'File 1: ' ) ; readln( name1 ) ; reset( f1, name1 ) ; write( 'File 2: ' ) ; readln( name2 ) ; reset( f2, name2 ) ; compare_files( f1, f2 ) ; END. { ----------------------- ST/XE Text File Converter 2 ----------------------- }{ ----------- utility to convert atascii text files to pure ascii ----------- }{ ------------------- (ignores all ctrl chars except eol) ------------------- }{ }{ ----------- by Craig Dickson, Sequoia Software, 9 February 1986 ----------- }{ ---------------------- Written in OSS Personal Pascal --------------------- }{ }{ ----------- This program is Copyright (c) 1986 Sequoia Software. ---------- }{ -- It may be freely distributed among users of Atari ST-series computers -- }{ ---------- provided only that it is not to be modified in any way --------- }{ ------------------ without the permission of the author. ------------------ }program convert_prg ; const {$I gemconst.pas} as_cr = 13 ; as_lf = 10 ; at_eol = 155 ; ignore = 1 ; low = 32 ; mask = 127 ; space = 32 ; soft_space = 30 ; type {$I gemtype.pas} txt_buf = array[ 1..12288 ] of char ; var first_word : boolean ; ch, dummy, mode, twhich, which : integer ; bin_path, bin_title, out_title : path_name ; alert : str255 ; bin_file, out_file : text ; buffer : txt_buf ; {$I gemsubs.pas} procedure show_off ; begin alert := '[0][ST/XE Text File Converter 2| by Craig Dickson' ; alert := concat( alert, '| | Compuserve PPN: 72257,1604| ]' ) ; alert := concat( alert, '[ OK ]' ) ; dummy := do_alert( alert, 1 ) ; alert := '[0][ (C) 1986 Sequoia Software.|Portions of ' ; alert := concat( alert, 'this product are| (C) 1986 OSS ' ); alert := concat( alert, 'and CCD.| Used by Permission of OSS.| ]' ) ; alert := concat( alert, '[ OK ]' ) ; dummy := do_alert( alert, 1 ) ; alert := '[0][This program is not to be sold|but may be ' ; alert := concat( alert, ' distributed freely| provided only ' ); alert := concat( alert, 'that it is| in no way modified.| ]' ) ; alert := concat( alert, '[ NO PROBLEM ]' ) ; dummy := do_alert( alert, 1 ) ; end ; procedure set_titles ; begin alert := '[2][Convert a file or quit?][ Convert | Quit ]' ; mode := do_alert( alert, 2 ) ; if mode <> 2 then begin alert := '[2][Convert to 1st Word format?][ Yes | No ]' ; first_word := (do_alert( alert, 2 ) = 1) ; bin_path := 'A:*.*' ; if length( bin_title ) > 0 then delete( bin_title, 1, length( bin_title ) ) ; if length( out_title ) > 0 then delete( out_title, 1, length( out_title ) ) ; if get_in_file( bin_path, bin_title ) then if not get_out_file( 'Enter output pathname:', out_title ) then mode := 2 ; end ; end ; procedure translate ; procedure op_files ; begin reset( bin_file, bin_title ) ; rewrite( out_file, out_title ) ; end ; procedure cl_files ; begin close( bin_file ) ; close( out_file ) ; end ; procedure load_file ; begin which := 0 ; repeat which := which + 1 ; if not eof( bin_file ) then begin read( bin_file, buffer[ which ] ) ; if (buffer[ which ] = chr( at_eol )) then which := which + 1 ; end else buffer[ which ] := chr( as_cr ) ; until (eof( bin_file )) or (which > 12287) ; end ; procedure save_file ; begin twhich := 0 ; repeat twhich := twhich + 1 ; if buffer[ twhich ] <> chr( ignore ) then write( out_file, buffer[ twhich ] ) ; until twhich = which ; end ; procedure load_ch ; begin ch := ord( buffer[ twhich ] ) ; if ch <> at_eol then ch := ch & mask ; end ; procedure save_ch( ch_p : integer ) ; begin buffer[ twhich ] := chr( ch_p ) ; end ; begin { translate } op_files ; repeat load_file ; twhich := 0 ; repeat twhich := twhich + 1 ; load_ch ; case ch of at_eol : begin save_ch( as_cr ) ; twhich := twhich + 1 ; save_ch( as_lf ) ; end ; space : begin if first_word then save_ch( soft_space ) else save_ch( space ) ; end ; otherwise : begin if ch < low then save_ch( ignore ) else save_ch( ch ) ; end ; end ; until twhich = which ; save_file ; until eof( bin_file ) ; cl_files ; end ; begin { convert_prg } if init_gem >= 0 then begin show_off ; repeat set_titles ; if mode <> 2 then translate ; until mode = 2 ; exit_gem ; end ; end.{ ---------------------------- end of convert_prg --------------------------- }`5tg o"h#7<#7@#7D,Oc.N//Bg?<JNA BbBy7HN /,HNVAT-HCE97p6QN2Hy9?NAN^ _ON/,HNVN4A&-H?<BgBg?<&?<NN-@/.?<Bg?<?<BgBgBgBgN=@/.?.AO"Op?"QBgBgN"n E4p$Qp.r"Aop"@/.?<Bg?<?<?<"?<Bg?<N=@/.?.CO$O"p!QCO$O"p!QAO"Op?"Q?<BgNz/.?<prArA??<?<?<?<?<?<N=@/.?.C$O$OBgBgN/.?<prA??<?<?<?<?<?<N=@/.?.CO$OpQBgBgN/.NpBnp=@/.?.N=@0.@e/.?.Bg?<N0.ngBnp=@`/.?.HnNDp.R@rAHnN&>/BgNl=@0.J@j p=@`r?.NhN2Hz?<!N2Hn?-@lHnN&>-@p?<ZHnHntHnlHnhN$0.vJ@f Bn`p=@HnN>HnN6"nE2p"Q"n E2p"Qp.=@Bn0.@eR0.J@W0.rA0p\@WÄC0.rA0p:@WÄCBd p=@` 0.S@=@`p=@p.=@f0.nfn,0.R@=@"n 0.2.tA0Rn`"n 0.@0.N^,_ _PNNu/,HNVN4Aj-H0.T@=@?.N-@/.?/?. N$F=@0.N^,_ _ONN0N1Nu/,HNVrN4?<MHnHn~HnvHnrN$"n2"n2"n2"n 2=n~0.N^,_ _ON/,HNV0N40. rAg p=@2` Hn0Hn0Hn0Hn0Nl=@pd=@2=n p=@ n n0.@rA1Rn`p=@?.2Bg?< BgHnHnHndHnLHn4BgN%=n0.N^,_ _TN/,HNVN%=@?.N%=n ?<fBg?<BgHnHn"n/ Hn"n/ BgN%?.N%N^,_ _O N/,HNV8N%=@:?. N%?. HnlHn/N$N^,_ _ON _(N _0/Ho |#37:Jy78fXNX/"_/$|5xa."|5a&Hy5t?<N$FJy7Hg _9N#NBgNAg`NuNu/,HNV-n=n ?<4HnHnHnHnN$=n0.N^,_ _\N _#Z#V#R#N#F#(J0/3| H |5"|H2H2H209 @pf2<`2<3"<F0<NBNu _<#n#f#j#b"_#^:3E3_3_ 2/3yr Jg( yfHSEk0 yz00 yx0Q?"<^0<sNBJ_g.:9H ynSEk0 yz00 yz0QNu _3rN09rNu _3tN09tNu _3z3xN _"_$_2z4xN _3~3|N _"_$_2~4|N _3vN09vNu _ RNB9`PBy7: _0g$_jp"_// HN(LJ@fP)J9f" f |` f|` f |` f|`4<G BQB) @ef *:f^&Jrt `e QG(ztWJBk4G(3 J9f g g`> g8 fp@`*S@rG   e gRAQJ9g`tJ)f8a J9g| _0< Hy(N#|#|3|Nu )bJ) g )g )g ) f J9fgHBNu|/ BgHi ?<ANA>3|NAXNu _4` _t6 Bo r aSB`2aNH?+B _r ar a/L?+BNu _r aN _4` _t"x0HgJJjDxvC+zp cRЀ`|e W0R"f`6 _4` _t2xJAjDAxvC+p0 2H@0RJAfJg<-RBlCSBr aQSCaQN _4v` _46"_JBjtClBSCr aQSBk aQN _v` _60@d C*t`C*tClBSCr aQSBavQNFALSETRUE _6kfv2_t Cc"4YBv` _6kfv"_t Cc4QBvSBkr a(QSCC" A0 9c^a JgYC`NH +2"oA/ N+L +2NuBy7:(_ _/ C( g  f,t4(H / /?(?<@NA LJkffNu4(SBraQNu(gN fH ??<NAXLNu f H ??<` f H ??<` f NuHy,m` Hy,F0< LN#REWRITE required prior to WRITE or PUTDisk or directory fullBy7: _$_"Wp )f)H/ N.L4NH/ N.Lp)`By7: _"WJy.f8J)f )f)H/ N.L )g)J)fJgBy. )g J)fBiNz`zBy7: _$_"WptvH/ Hya029XL- -fJf^p`4  fJg*`N0eH  bBԂi\(؄iV؄iRԄiNԁRCJ)f  g )f) 0e 9c~Jg&JgDJf 6Höf4N$NHy.0<` Hy.0<N#By7: _$_0"Wt )gJ&JRJ)f4H/ HyaP29XL )gJ)f RBBe`ưBe`N&|H/ ?< NA\Hy.?< NA\LS@kQ3.N Bad digit in number encounteredOverflow during READ of numberBy7:(_ _/ C (g ( fxJ(f t4($IH / /?(?<?NA LJk,g*fJg  f"J` g  Wf NuJgJ(f P Nu!|Nu4(SBa@J(f8Jg. fJ(f"gr W1Agp f W1A1AQNu(gVJ(fD f&H`?<NAT f?< ?<NAXp LNu fH`?<NATLNuHy0\0<` Hy080< LN#Reset required prior to Read or GetAttempt to read past end-of-file 70 @f0"|p` "_J@jp6B@bESBkQ/LNuString overflow _ hNVf 0(gr"OD@Hd2S@k "Q` _"y7<e Hy5FN$N## .f -|56`-|56 nNнf yNStack overruns heap097:Nu _378NBy7:Nu[3][][ Abort ]Copyright 1986, CCD and OSS, Inc. ,           "     *  2 (  H$(LV2(., ",.*&d&0.4\.0DX<"$>,$8(l*lrh\,&D0T>0,8&&, D"2 T &( 0&  >         HB@6 2J X D   ( 0"L2 T  <   , FR ( *@ B @ B  PROGRAM copy_pas ; CONST chunk_size = 4096 ; fn_length = 64 ; TYPE buffer_type = PACKED ARRAY [ 1..chunk_size ] OF byte ; file_name_type = PACKED ARRAY [ 1..fn_length ] OF char ; VAR fname : STRING ; buf : buffer_type ; i, in_file, out_file : integer ; name : file_name_type ; FUNCTION gem_create( VAR fname : file_name_type ; mode : integer ) : integer; GEMDOS( $3C ) ; FUNCTION gem_open( VAR fname : file_name_type ; mode : integer ) : integer; GEMDOS( $3D ) ; PROCEDURE gem_close( handle : integer ) ; GEMDOS( $3E ) ; FUNCTION gem_read( handle : integer ; nbytes : long_integer ; VAR buf : buffer_type ) : long_integer ; GEMDOS( $3F ) ; FUNCTION gem_write( handle : integer ; nbytes : long_integer ; VAR buf : buffer_type ) : long_integer ; GEMDOS( $40 ) ; PROCEDURE gem_seek( nbytes : long_integer ; handle, mode : integer ) ; GEMDOS( $42 ) ; PROCEDURE copy_file( in_file, out_file : integer ) ; VAR n : long_integer ; BEGIN REPEAT gem_close( out_file ) ; { Close down the output! } out_file := gem_open( name, 1 ) ; gem_seek( 0, out_file, 2 ) ; { Seek end-of-file } n := gem_read( in_file, chunk_size, buf ) ; writeln( 'read chunk of ', n, ' bytes' ) ; IF n < 0 THEN BEGIN writeln( 'error ', n, ' on input file' ) ; halt ; END ELSE IF n > 0 THEN IF gem_write( out_file, n, buf ) = n THEN writeln( 'wrote chunk properly' ) ELSE BEGIN writeln( 'error writing output file' ) ; halt ; END ; UNTIL n = 0 ; END ; BEGIN write( 'Source file: ' ) ; readln( fname ) ; FOR i := 1 TO length( fname ) DO name[i] := fname[i] ; name[ length(fname) + 1 ] := chr(0) ; in_file := gem_open( name, 0 ) ; IF in_file >= 0 THEN writeln( 'opened input file' ) ELSE BEGIN writeln( 'error ', in_file, ' opening input' ) ; halt ; END ; write( 'Destination file: ' ) ; readln( fname ) ; FOR i := 1 TO length( fname ) DO name[i] := fname[i] ; name[ length(fname) + 1 ] := chr(0) ; out_file := gem_create( name, 0 ) ; IF out_file >= 0 THEN writeln( 'opened output file' ) ELSE BEGIN writeln( 'error ', out_file, ' opening output' ) ; halt ; END ; copy_file( in_file, out_file ) ; gem_close( in_file ) ; gem_close( out_file ) ; END.  March 4, 1986 Instructions for COPY2.PRG Program and documentation by David Duberman This program was inspired by a public domain program called COPY.PRG, written in assembler and distributed with two excellent RAMdisk programs by the same author. Unfortunately, the original COPY.PRG copies a byte at a time, so even in assembler works rather slowly. COPY2.PRG was written in OSS Personal Pascal, and uses a GEMDOS call to copy up to 32,000 bytes in one fell swoop. The result is an increase in copying speed of at least 300%! Since most people will be using this to copy files to drive C: (RAMdisk), this program avoids making you specify this in the list of files to be copied. Changing the destination drive spec is as simple as changing a character in the source file (COPY2.PAS) and recompiling. This program is intended to be placed in an AUTO folder after placing a RAMdisk program in the folder. When run, it reads an ASCII list of files to be copied to drive C:. The name of the list should be FILE.LST and it should appear in the root directory of the boot disk. If you use ST Writer to create the list, print it to disk with top, left, and bottom margins of 0, a right margin of 80, and page length (^Y) of 2. If you use First Word, turn off WP mode before saving the file. You can include path information, e.g. A:\UTILS\JUNK.PRG is permissible. After creating the FILE.LST list, create an AUTO folder on the disk and copy a RAMdisk program into it. Michtron M-Disk works fine, but you may want to use one of the public domain RAMdisks that do not require you to specify a size for the disk when run. Then copy COPY2.PRG into the folder. Of course, the files to be copied should also be on the boot disk, or else on a disk in drive B: upon booting. You may then copy any files you want run automatically after the copy program into the AUTO folder. Then boot this disk, and all your files will be copied to the RAMdisk automatically, and FAST. PROGRAM copy2_pas ; {Written in OSS Personal Pascal -- original from OSS -- revision by David Duberman 3/86} {Copies list of files in ASCII text file FILE.LST in root directory to drive C: -- Place in AUTO folder after copying ramdisk utility into folder} CONST chunk_size = 32000 ; fn_length = 64 ; TYPE buffer_type = PACKED ARRAY [ 1..chunk_size ] OF byte ; file_name_type = PACKED ARRAY [ 1..fn_length ] OF char ; VAR fname : STRING ; buf : buffer_type ; i,j,in_file, out_file : integer ; name : file_name_type ; t: text; FUNCTION gem_create( VAR fname : file_name_type ; mode : integer ) : integer; GEMDOS( $3C ) ; FUNCTION gem_open( VAR fname : file_name_type ; mode : integer ) : integer; GEMDOS( $3D ) ; PROCEDURE gem_close( handle : integer ) ; GEMDOS( $3E ) ; FUNCTION gem_read( handle : integer ; nbytes : long_integer ; VAR buf : buffer_type ) : long_integer ; GEMDOS( $3F ) ; FUNCTION gem_write( handle : integer ; nbytes : long_integer ; VAR buf : buffer_type ) : long_integer ; GEMDOS( $40 ) ; PROCEDURE gem_seek( nbytes : long_integer ; handle, mode : integer ) ; GEMDOS( $42 ) ; PROCEDURE copy_file( in_file, out_file : integer ) ; VAR n : long_integer ; BEGIN REPEAT n := gem_read( in_file, chunk_size, buf ) ; {writeln( 'read chunk of ', n, ' bytes' ) ;} IF n < 0 THEN BEGIN writeln( 'error ', n, ' on input file' ) ; halt ; END ELSE IF n > 0 THEN IF gem_write( out_file, n, buf ) <> n THEN BEGIN writeln( 'error writing output file' ) ; halt ; END ; UNTIL n = 0 ; END ; BEGIN Writeln; Writeln('Fast File Copy Utility'); Writeln; Writeln('Written in OSS Personal Pascal'); Writeln; Writeln('Portions copyright (c) 1986 OSS & CCD'); Writeln; Writeln('Used by permission of OSS'); Writeln; Reset(t,'file.lst'); while not eof(t) do begin readln(t,fname); writeln; writeln('Copying ',fname); FOR i := 1 TO length( fname ) DO name[i] := fname[i] ; name[ length(fname) + 1 ] := chr(0) ; in_file := gem_open( name, 0 ) ; IF in_file < 0 THEN BEGIN writeln( 'error ', in_file, ' opening input' ) ; halt ; END ; name[1] := 'c'; name[2] := ':'; FOR i := 1 TO length( fname ) DO name[i+2] := fname[i] ; name[ length(fname) + 3 ] := chr(0) ; out_file := gem_create( name, 0 ) ; IF out_file < 0 THEN BEGIN writeln( 'error ', out_file, ' opening output' ) ; halt ; END ; copy_file( in_file, out_file ) ; gem_close( in_file ) ; gem_close( out_file ) ; end; close(t) END. `j6 o"h###Bb3NN:NV?./. ?<NAN^ _ONNV/./. ?.?<?NAN^ _O NNV/./. ?.?<@NAN^ _O NNV?.?. /. ?<BNAN^ _ONCOPY_FILE ?Hz~4/,HNVNxA-HP~5~5?.0<}H/HydN\-@~6~7 .JjT~8~9HybHz?<N /.N Hz?<N N X~:N yN~;~<``~< .roR~=?./.HydNg6~>~?HybHzD?<N N X~@N yN~A~B .Jf~CN^,_X> _XNerror writing output file on input fileerror A0B1|Ab01|A01|~FAz#HybN XHybHz ?<N N XHybN X~GHybHz?<N N XHybN X~HHybHzp?<%N N XHybN X~IHybHz*?<N N XHybN X~JHyHz?<N~K~K09@e~LHy?<PHyNpN 6X~MHybN X~NHybHz?<N Hy?~P~P09j2|C?29jCPtA0AkRyj`~Qp9R@2|C?rAk~RHylBgN3f~S09fJ@jH~T~UHybHz?<N ?9fN 8Hz?<N N X~V yN~W~Xpcl~Yp:m~Zp3jp93\09jy\n@~[~[09jT@2|C?29jCPtA0AkRyj`~\p9V@2|C?rAk~]HylBgN3d~^09dJ@jH~_~`HybHz?<N ?9dN 8Hz~?<N N X~a yN~b~c?9f?9dN6~d?9fN~e?9dN~f`t~gHyN V~hHyN VHybN VN" opening output opening inputerror Copying file.lstUsed by permission of OSSPortions copyright (c) 1986 OSS & CCDWritten in OSS Personal PascalFast File Copy UtilityB9^`P^By _0g$_jp"_// H`N VL`J@fP)J9^f" f |` f|` f |` f|`4<G BQB) @ef *:f^&Jrt `e QGtWJBk4G3 J9^f g g`> g8 fp@`*S@rG   e gRAQJ9^g`tJ)f8a J9^g| _0< Hy N|#|3|Nu )bJ) g )g )g ) f J9^fgHBNu|/ BgHi ?<ANA>3|NAXNu _4` _t6 Bo r aSB`2aNH? _r ar a/L? Nu _r aN _4` _t"x0HgJJjDxvC zp cRЀ`|e W0R"f`6 _4` _t2xJAjDAxvC p0 2H@0RJAfJg<-RBlCSBr aQSCaQN _4v` _46"_JBjtClBSCr aQSBk aQN _v` _60@d C t`C tClBSCr aQSBavQNFALSETRUE _6kfv2_t Cc"4YBv` _6kfv"_t Cc4QBvSBkr a(QSCC" A0 9c^a JgYC`NH "oA/ N L NuBy(_ _/ C( g  f,t4(H / /?(?<@NA LJkffNu4(SBraQNu(gN fH ??<NAXLNu f H ??<` f H ??<` f NuHy ` Hy 0< LNREWRITE required prior to WRITE or PUTDisk or directory fullBy _$_"Wp )f)H/ NVL4NH/ NVLp)`By _"WJyf8J)f )f)H/ NVL )g)J)fJgBy )g J)fBiNz`zBy _$_"WptvH/ Hyla029lXL- -fJf^p`4  fJg*`N0eH  bBԂi\(؄iV؄iRԄiNԁRCJ)f  g )f) 0e 9c~Jg&JgDJf 6Höf4N$NHy70<` Hy0<NBy _$_0"Wt )gJ&JRJ)f4H/ HylaP29lXL )gJ)f RBBe`ưBe`N&|nH/ ?< NA\Hy?< NA\LS@kQ3N Bad digit in number encounteredOverflow during READ of numberBy(_ _/ C (g ( fxJ(f t4($IH / /?(?<?NA LJk,g*fJg  f"J` g  Wf NuJgJ(f P Nu!|Nu4(SBa@J(f8Jg. fJ(f"gr W1Agp f W1A1AQNu(gVJ(fD f&H`?<NAT f?< ?<NAXp LNu fH`?<NATLNuHy0<` Hy0< LNReset required prior to Read or GetAttempt to read past end-of-file~,GxvGIp/??<NM(PRDQNuHy?< NA\xvIp/??<NMPRDQBgNAHym`Hy`Hy?< NA\Hy?< NA\ o`>Hy&`Hy7?< NA\HyL?< NA\ oa.Hy?< NA\ o /Hy?< NA\ _p "f/Hy?NA\ _`^"nH .gHy&`JkHy`Hy?NA\L/ .fjXt AH ??<NAXLQ/Hy ?< NA\t&<'HǏf CgJfr `t20/??<NAX$HG fHy?< NA\ _a6 gz .f >. n` n,n/Hy?< NA\ _`/?<$?<NAX _tv"0 :e^H ??<NAXLYCQNut|BJR *** Bus error *** Address error - attempt to reference address *** Attempt to divide by zero *** Value out of range *** Integer overflow *** Error in Called by PROCEDURE FUNCTION MAIN PROGRAM at source line at PC function or procedure compiled w/o DEBUG _ hNVf 0(gr"OD@Hd2S@k "Q` _"ye HyNN## .f -|`-| nNнf yNStack overruns heap _(N _0/Ho |3JyfXNX/#"|ja "_a"|qaJyg y9BgNA/ ?< NA\Nu09Nu _3NByNu *** *** Copyright 1986, CCD and OSS, Inc."   ( T                   HB@6 2J X D   ( 0"L2 T  0) and ((istr[1] < '0') or (istr[1] > '9'))) do delete(istr,1,1); if length(istr) > 0 then begin more := true; while more do begin if (istr <> '') and (istr[1] in ['0'..'9']) then begin ret_value := (ret_value * 10) + (ord(istr[1]) - ord('0')); delete(istr,1,1); end else more := false; end; end; str_to_int := ret_value; end; procedure display_date_and_time; begin date_and_time := get_datetime; sys_date := int(shr(date_and_time,16) & $0000ffff); month := shr(sys_date,5) & $000f; day := sys_date & $001f; year := shr(sys_date,9) & $003f; year := year + 80; writeln('Current Date ',month:2,'/',day:2,'/',year:2); sys_time := int(date_and_time & $0000ffff); hour := shr(sys_time,11) & $001f; minute := shr(sys_time,05) & $003f; second := sys_time & $001f; second := second * 2; writeln('Current Time ',hour:2,':',minute:2,':',second:2); end; procedure set_the_date; var done: boolean; begin repeat write('enter the Date or return '); readln(sdate); if length(sdate) > 0 then begin month := str_to_int(sdate); day := str_to_int(sdate); year := str_to_int(sdate); if year > 1900 then year := year - 1900 else if year > 80 then year := year - 80; sys_date := shl(year,9) | shl(month,5) | day; if set_date(sys_date) = 0 then done := true else begin writeln('The System did not like that date! Try again'); done := false; end; end else done := true; until done; end; procedure set_the_time; var done: boolean; begin repeat write('enter the Time or return '); readln(stime); if length(stime) > 0 then begin hour := str_to_int(stime); minute := str_to_int(stime); second := str_to_int(stime); second := second div 2; sys_time := shl(hour,11) | shl(minute,5) | second; if set_time(sys_time) = 0 then done := true else begin writeln('The System did not like that time! Try again'); done := false; end; date_and_time := sys_date; date_and_time := shl(date_and_time,16) + sys_time; set_datetime(date_and_time); end; until done; end; procedure set_date_and_time; begin writeln; set_the_date; set_the_time; end; procedure reset_datetime; begin set_date_and_time; display_date_and_time; writeln; write('Is this correct? '); readln(reply); end; begin retcd := cursconf(3,0); retcd := cursconf(1,0); repeat display_date_and_time; if (year >= 86) and (month >= 01) and (day >= 01) then begin writeln; write('Reset the Date and Time? '); readln(reply); if (reply <> '') and (reply[1] in ['Y','y']) then reset_datetime else reply := ''; end else reset_datetime; until ((reply <> '') and (reply[1] in ['Y','y'])) or (reply = ''); end. (* Degasgen, Translate .RLE file into a Degas .PI1 file FUNCTION: Degasgen takes a CompuServe Run Length Encoded (.RLE) format file and translates it into a DEGAS low resolution (.PI1) file suitable for editing with DEGAS. USAGE: The program is a .TOS file; it will prompt you for the names of two files: an RLE file and then a .PI1 file. If the .PI1 file already exists, it will be overwritten. NOTES: RLE format files have a resolution of 256 wide by 192 deep. DEGAS .PI1 files have a resolution of 320 wide by 200 deep. Not only that, but they have 16 levels of color per pixel, whereas RLE files are strictly black or white. Thus, you may assume that RLE files do not tax the abilities of DEGAS. On the other hand, you can view RLE files on Commodore 64s, Atari 800s, Apples, etc. AUTHOR: Charles McGuinness, May 1986 MODIFICATIONS: *) program degasgen; type timage = array [0..15999] of integer; var image : ^timage; (* The Degas Image *) inf : packed file of byte; (* What we read *) outf : file of integer; (* What we write *) line : string; (* Throw away string *) i : integer; c : byte; currow, curcol, black, white, white2 : integer; sdot : integer; (* The following two functions are defined by the Personal Pascal *) (* Compiler. *) procedure io_check(b:boolean); external; function io_result: integer; external; (* SET_PIX: *) (* *) (* Sets the specified pixel in the DEGAS image to either black *) (* or white (b=0 means black, b=1 means white). *) (* *) (* Note that in low resolution mode, each pixel on the ST's *) (* screen is represented by four bits in the screen. That's *) (* why we go through the fun of all this bit magic. *) (* *) (* Trust me, it works. *) procedure set_pix(x,y,b : integer); var normal, offset,u : integer; begin offset := (y * 80) + ((x div 16)*4); normal := 15 - (x & 15); u := shl(b,normal); image^[offset+0] := image^[offset+0] | u; image^[offset+1] := image^[offset+1] | u; image^[offset+2] := image^[offset+2] | u; image^[offset+3] := image^[offset+3] | u; end; (* How to exit the program from any point, and do it *) (* so that the user has a chance to see what's gone on *) procedure my_halt; begin write('Press RETURN to continue: '); readln; halt; end; procedure inc_sdot; begin sdot := sdot + 1; if ((sdot mod 64) = 0) then begin writeln; write('<',sdot:5,'>'); end; write('.'); end; begin (* MAIN *) writeln('Degas to RLE Conversion program, version 1.0'); writeln; writeln('Copyright (C) 1986, Charles McGuinness'); writeln; writeln('Portions of this product are Copyright (c) 1986, OSS and CCD.'); writeln('Used by Permission of OSS.'); (* Yes, this is personal pascal *) writeln; new(image); for i:=0 to 15999 do begin image^[i] := 0; (* Set the image to BLACK *) end; (* Open the input, output files.... *) write('Input (.RLE) file: '); readln(line); IO_Check(FALSE); reset(inf,line); i := io_result; if (i <> 0) then begin writeln('I was unable to open ',line); my_halt; end; io_check(TRUE); write('Output (.PI1) file: '); readln(line); io_check(FALSE); rewrite(outf,line); i := io_result; io_check(TRUE); if (i <> 0) then begin close(inf); writeln('I was unable to create ',line); my_halt; end; repeat c := inf^; get(inf); until (c & 127 = 27); (* Search for escape *) get(inf); get(inf); (* Eat the G H *) curcol := 0; currow := 0; sdot := 0; writeln; write('< 0>.'); repeat black := (inf^ & 127) -32; get(inf); if (black >= 0) then begin white := (inf^ & 127)-32; get(inf); end; if ((black >= 0) and (white >= 0)) then begin curcol := curcol + black; if (curcol >= 256) then begin inc_sdot; curcol := curcol - 256; currow := currow + 1; end; repeat white2 := 0; if ((curcol+white) >= 256) then begin inc_sdot; white2 := white+curcol - 256; white := 256 - curcol; end; if (white <> 0) then for i:= curcol to curcol+white-1 do set_pix(i,currow,1); curcol := curcol + white; if curcol = 256 then begin curcol := 0; currow := currow + 1; end; white := white2; until (white = 0); end; until ((white < 0) or (black < 0)); writeln; writeln('Generating output file now ....'); outf^ := 0; put(outf); for i :=0 to 15 do begin outf^ := (i div 2) * $111; put(outf); end; sdot := 0; for i := 0 to 15999 do begin if ((sdot mod (80*64)) = 0) then begin writeln; write('<',(sdot div 80):5,'>'); end; if ((sdot mod 80) = 0) then write('.'); sdot := sdot + 1; outf^ := image^[i]; put(outf); end; writeln; close(outf); close(inf); end. `6t o"h###Bb3NFNSET_PIX ?Hz~L/,HNVNAL-HP0.P2.tHAA=@~Np2.tBA=@~O0.2.h=@~Q"yn/ NR0.A>@$yn/ NR0.A>@0n2~R"yn/ NR0.R@A>@$yn/ NR0.R@A>@0n2~S"yn/ NR0.T@A>@$yn/ NR0.T@A>@0n2~T"yn/ NR0.V@A>@$yn/ NR0.V@A>@0n2~UN^,_X> _\NMY_HALT ?Hz~[/,HNVNAD-HPHyHzNuPress RETURN to continue: INC_SDOT ?Hz~b/,HNVNA-HP09 2R@3 2~d09 2r@HH@J@fB~eHyN X~fHy?<NX~g~iHy?<.NX~jN^,_X>NuA0B1|A01|A"BP1|ArBP1|~nA# HyHz?<,NN X~oHyN X~pHyHzF?<&NN X~qHyN X~rHyHz?<=NN X~sHyHz?<NN X~tHyN X~v?<}HynN~xBy $ y> $n.~x~y"yn/ NR09 $A>@BQ~zRy $`~|~~HyHz ?<NX~Hy?<PHyNNX><BgN><HyrHy?<N3 $><09 $J@g>><HyHzv?<NHy?<N><><?<N><HyHz?<NX><Hy?<PHyNNX><BgN><Hy"Hy?<N3 $><?<N><09 $J@gN><HyrN><HyHz`?<NHy?<N><><><><C p)A3 &><HyrN><09 &rArAf><HyrN><HyrN><By .><By 0><By 2><HyN X><HyHz?<NX><><><C p)rA@3 ,><HyrN><09 ,J@k4><C p)rA@3 *><HyrN><><09 ,J@Z09 *J@ZCBd><09 .y ,3 .><09 .|m4><N><09 .@3 .><09 0R@3 0><><><><By (><09 .y *|m<><N><09 *y .@3 (><0<y .3 *><><09 *J@gX><3 . $09 .y *S@3 409 $y 4n&><><?9 $?9 0?<NRy $`><09 .y *3 .><09 .|f"><By .><09 0R@3 0><><3 ( *><09 *J@f><><09 *J@[09 ,J@[ÄCBd><HyN X><HyHz?<NN X><CBQ><Hy"ND><By $ y $n>><><C09 $rH2><Hy"ND><Ry $`><By 2><By $ y> $n><><09 2rPAHH@J@fP><HyN X><Hy?<NX><><09 2rPHH@J@f><Hy?<.NX><09 2R@3 2><C$yn/ NR09 $A>@2><Hy"ND><Ry $`><HyN X><Hy"N><HyrN><HyrNHy"NHyNN~Generating output file now ....< 0>.I was unable to create Output (.PI1) file: I was unable to open Input (.RLE) file: Used by Permission of OSS.Portions of this product are Copyright (c) 1986, OSS and CCD.Copyright (C) 1986, Charles McGuinnessDegas to RLE Conversion program, version 1.0B9 6`P 6By _0g$_jp"_// H 8NL 8J@fP)J9 6f" f |` f|` f |` f|`4<G BQB) @ef *:f^&Jrt `e QG g8 fp@`*S@rG   e gRAQJ9 6g`tJ)f8a J9 6g| _0< HyZN\|#|3|Nu )bJ) g )g )g ) f J9 6fgHBNu|/ BgHi ?<ANA>3|NAXNu _4` _t6 Bo r aSB`2aNH? _r ar a/L?Nu _r aN _4` _t"x0HgJJjDxvCDzp cRЀ`|e W0R"f`6 _4` _t2xJAjDAxvCDp0 2H@0RJAfJg<-RBlCSBr aQSCaQN _4v` _46"_JBjtClBSCr aQSBk aQN _v` _60@d Cgt`CbtClBSCr aQSBavQNFALSETRUE _6kfv2_t Cc"4YBv` _6kfv"_t Cc4QBvSBkr a(QSCC" A0 9c^a JgYC`NH "oA/ NDL NuBy(_ _/ C( g  f,t4(H / /?(?<@NA LJkffNu4(SBraQNu(gN fH ??<NAXLNu f H ??<` f H ??<` f NuHy/` Hy0< LN\REWRITE required prior to WRITE or PUTDisk or directory fullBy _$_"Wp )f)H/ NL4NH/ NLp)`By _"WJyhf8J)f )f)H/ NL )g)J)fJgByh )g J)fBiNz`zBy _$_"WptvH/ Hy Da029 DXL- -fJf^p`4  fJg*`N0eH  bBԂi\(؄iV؄iRԄiNԁRCJ)f  g )f) 0e 9c~Jg&JgDJf 6Höf4N$NHy0<` Hym0<N\By _$_0"Wt )gJ&JRJ)f4H/ Hy DaP29 DXL )gJ)f RBBe`ưBe`N&| FH/ ?< NA\Hyj?< NA\LS@kQ3hN Bad digit in number encounteredOverflow during READ of numberBy(_ _/ C (g ( fxJ(f t4($IH / /?(?<?NA LJk,g*fJg  f"J` g  Wf NuJgJ(f P Nu!|Nu4(SBa@J(f8Jg. fJ(f"gr W1Agp f W1A1AQNu(gVJ(fD f&H`?<NAT f?< ?<NAXp LNu fH`?<NATLNuHy0<` Hy0< LN\Reset required prior to Read or GetAttempt to read past end-of-file Nu# _ ged 9NHy&`Hy2Nrt`t _"_0gR@| e.G $S" ghjebb"*f&"`v&A%S"`l&J`ذ|gb*|f8"9g0$A#`""9g$A#`"9g $A#"`"E&R"$b HyNrJgr"QHd2S@k"QN _"_0" ged gR@ @mz @ e@E "fB3@B$`\&A2+@ef "'I`F"3@B$`8$K`ư|f"#` |f"#` "#NHeap overruns stackPointer NILPointer not in heap~,GxvGjI!H/??<NM(PRDQNuHy ?< NA\xvI!H/??<NMPRDQBgNAHy`Hy`Hy?< NA\Hy?< NA\ o`>Hy`Hy?< NA\Hy?< NA\ oa.Hy?< NA\ o /Hy#?< NA\ _p "f/HyS?NA\ _`^"nH .gHy`JkHy=`HyH?NA\L/ .fjXt AH ??<NAXLQ/Hyh?< NA\t&<'HǏf CgJfr `t20/??<NAX$HG fHyy?< NA\ _a6 gz .f >. n` n,n/Hy0?< NA\ _`/?<$?<NAX _tv"0 :e^H ??<NAXLYCQNu *** Bus error *** Address error - attempt to reference address *** Attempt to divide by zero *** Value out of range *** Integer overflow *** Error in Called by PROCEDURE FUNCTION MAIN PROGRAM at source line at PC function or procedure compiled w/o DEBUG _ hNVf 0(gr"OD@Hd2S@k "Q` _"ye Hy.NrN#!h#!d .f -|`-| nNн!df y!hNStack overruns heap _(N _0/Ho |B3JyfXNX/#!l"|a "_a"|aJyg y!l9BgNA/ ?< NA\Nu09Nu _3NByNu *** *** Copyright 1986, CCD and OSS, Inc. PF  H                                                    0 HB@6 2J X D   ( 0"L2 T  <   , FX  chr(0)) DO BEGIN write( name[i] ) ; i := i + 1 END ; writeln ; END ; END ; BEGIN write( 'search path: ' ) ; readln( path_string ) ; FOR i := 1 TO length( path_string ) DO path[i] := path_string[i] ; path[ length(path_string)+1 ] := chr(0) ; set_dta( r ) ; IF get_first( path, 0 ) < 0 THEN writeln( 'no files match specification!' ) ELSE REPEAT show_file( r ) ; UNTIL get_next < 0 ; END. {* File: DSEEK.PAS *} {*********************************************************************** * D S E E K * ------------- * Purpose: * A simple program to set the disk seek rate for drive B to 6 ms. * * Notes: * I was told that if I set the memory location $0A0D to $00 I would * be setting the disk seek rate for drive B to 6 ms. * * This only works with ROM TOS. * * This program was developed with OSS's Personal PASCAL. * * The program uses some machine language modules I developed to * access 'supervisor mode' memory locations. * * David Story Feb. 22, 1986 Original Development ***********************************************************************} program dseek; const {$I GEMCONST.PAS} type {$I GEMTYPE.PAS} var alert: str255; choice: integer; {* External Modules *} {$I GEMSUBS.PAS} {$I A:\UTIL\PEEKPOKE.INC} {********************** DSEEK mainline ************************} begin {* dseek *} if (Init_Gem >= 0) then begin alert:= '[0][ Set drive B seek rate | to 6 ms ][ OK | CANCEL ]'; choice:= Do_Alert(alert, 1); if (choice = 1) then begin pokei($00000A0C,$0000); end; Exit_Gem; end; {* (init_gem >= 0) *} end. {* dseek *} ` 2 o"h# # #,Oc.N//Bg?<JNA Bb3NNXA 0B1|A01|~+A#NJ@kr~,~.C~El3|NAXNu _ hNVf 0(gr"OD@Hd2S@k "Q` _"y e Hy N N## .f -| `-|  nNнf yNStack overruns heap09 Nu _3 NBy Nu[3][][ Abort ]Copyright 1986, CCD and OSS, Inc. . B  "    8@F D"2 T &( 0&  >        t  { dump - Show the contents of a file in hexadecimal and ASCII. This is not a very sophisticated dump program, but it does further illustrate file access with Pascal, and it also demonstrates columnar output. Possible extensions are: GEM interface, ability to divert output to a file or the printer, starting position within file, dump in ASCII or hex only, etc. } PROGRAM dump; CONST chunk_size = 16; { Number of bytes to display per line. 16 is almost } { maximum for 80 character lines, since we need 3 } { characters for the hexadecimal value (with a space) } { and one character for the ASCII. 16*3+16 = 64, and } { 8 characters for the file position gives 72. } TYPE { For each line we display, we have to hold all the bytes in a buffer, so we can print out the hex and then the ASCII. } chunk_range = 1..chunk_size; chunk_buf = PACKED ARRAY[ chunk_range ] OF byte; VAR chunk : chunk_buf; { Buffer for bytes of current display line } offset : long_integer; { Current file offset position } n : 0..chunk_size; { Number of bytes in current chunk } f : PACKED FILE OF byte; { Our input file-- it's binary! } name : STRING; { Finally, the name of our input file } { dump_chunk - Read a chunk from the input file and display it on the current line. 'chunk_size' bytes are always read, except possibly for the last chunk, which may be shorter if end-of-file is encountered. } PROCEDURE dump_chunk; VAR i : chunk_range; { Used to index into the current chunk } BEGIN { While we don't yet have a full chunk, and we haven't reached the end of the file, read one byte and add it to the chunk. The variable 'n' is used to keep track of how many bytes we have added. } n := 0; WHILE (n < chunk_size) AND NOT eof(f) DO BEGIN n := n + 1; chunk[n] := f^; get( f ); END; { OK, we have a chunk of 'n' bytes. Write the current file offset and the hexadecimal byte values. } write( offset:6:h, ': ' ); FOR i := 1 TO n DO write( chunk[i]:2:h, ' ' ); { If we have fewer than 'chunk_size' bytes in this chunk, we must put out some spaces so the ASCII data lines up with that of the previous line } FOR i := n+1 TO chunk_size DO write( ' ' ); { Now put out the ASCII data. If the character we are putting out isn't printable, use a period, instead. We aren't checking for characters over 127, since they print OK on the console screen, but if you modify this program to go to a printer, you might want to change those to periods, also. } write( '"' ); FOR i := 1 TO n DO IF ord(chunk[i]) < ord(' ') THEN write( '.' ) ELSE write( chr(chunk[i]) ); writeln( '"' ); offset := offset + n; END; { main routine - Ask the user for the name of the file to dump, open it, and dump chunks until end-of-file is reached. } BEGIN write( 'File to dump: ' ); readln( name ); reset( f, name ); offset := 0; WHILE NOT eof(f) DO dump_chunk; END. { PROGRAM - COPY.PAS PURPOSE - 1. Demo of Personal Pascal Printer, Disk, and Console I/O 2. Do a reasonable job of printing files. PROBLEMS - may be somewhat naive about screen control characters, like BS. I took this example program and embellished it to do a little GEM. Seems like hardly no one is doing pascal out there. Like to change that! Oh, please excuse the goto. I is an old Fortran programmer, and don't know no better! } program copy (input, output, input_file, output_file); label 2; const {$I GEMCONST.PAS} type {$I GEMTYPE.PAS} character = -1..127; var Alert_string, In_Name, Out_Name, Def_path: Str255; Choice, Which : integer; Dummy : char; C : Character; End_Line : Boolean; Input_File, Output_File : File of Text; {$I GEMSUBS} function current_disk : integer; gemdos($19); function getc (var c : character) : character; var ch : char; begin End_Line := eoln(input_file); If not eof(input_file) then begin read(input_file,ch); c := ord(ch) End; getc := c end; procedure putc(c : character); begin if End_Line then begin writeln(output_file,chr(c)); End_Line := false; end else write(output_file,chr(c)); end; begin End_Line := false; If INIT_GEM >= 0 then begin Alert_string := '[0][ The Copy Procedure | | From the book | '; Alert_string := Concat(Alert_string, 'Software Tools in Pascal | '); Alert_string := Concat(Alert_string, ' by Kernighan & Plauger ][ OK ]'); Choice := Do_alert(Alert_string,0); Alert_string := '[0][ Modified for the ST | by The Vaxrat | '; Alert_string := Concat(Alert_string, 'Parts c1986 OSS & CCD. | '); Alert_string := Concat(Alert_string, ' Used with Permission | ]'); Alert_string := Concat(Alert_string, '[ Sure ]'); Choice := Do_alert(Alert_string,1); Alert_string := '[0][ Call the Webbed Sphere! | (513) 299-3665 | '; Alert_string := Concat(Alert_string,'300/1200 Baud 24 hrs a day | '); Alert_string := Concat(Alert_string,'Tell Webby Vaxrat sent ya! | ]'); Alert_string := Concat(Alert_string,'[ Get on with it! ]'); Choice := Do_alert(Alert_string,1); Alert_string := '[2][ | Select Input Source | ]'; Alert_string := Concat(Alert_string, '[ Disk | Keys ]'); Choice := Do_alert(Alert_string,0); If Choice = 1 then Begin IN_Name := ''; which := current_disk; case which of 1 : Def_path := 'B:\*.TXT'; 2 : Def_path := 'C:\*.TXT'; 3 : Def_path := 'D:\*.TXT'; otherwise : Def_path := 'A:\*.TXT' End; If Not Get_in_file(Def_path, IN_Name) Then GOTO 2; Reset(Input_file, in_name); end else Reset(Input_file, 'CON:'); Alert_string := '[0][ Select Output Source | ]'; Alert_string := Concat(Alert_string, '[ Disk | LPR | Mon ]'); Choice := Do_alert(Alert_string,0); Case Choice of 1 : Begin If Not Get_Out_File('Output File Name?',Out_Name) Then Goto 2; Rewrite(Output_file,out_name) End; 2 : Begin Out_Name := 'PRN:'; Alert_string := '[1][ Ready to Print! | Make sure that the |'; Alert_string := Concat(Alert_string,' Printer is Ready! ]'); Alert_string := Concat(Alert_string,'[ Ok | Abort ]'); Which := Do_alert(Alert_string,0); If which = 2 then Goto 2; Rewrite(Output_file,out_name); writeln(output_file,chr(27),chr(78),chr(6)) End; 3 : Begin Out_Name := 'CON:'; Alert_string := '[1][ Ready to Print! | | Use Control-S/Q to |'; Alert_string := Concat(Alert_string,' Stop Scrolling. ]'); Alert_string := Concat(Alert_string,'[ Ok | Abort ]'); Which := Do_alert(Alert_string,0); If which = 2 then Goto 2; Rewrite(Output_file,out_name); Hide_Mouse; Clear_Screen; End End End; while not eof(input_file) do begin c := getc(c); putc(c) end; 2 :Case Choice of 3 : Begin Writeln(output_file); Writeln('Press to continue...'); Read(dummy) End; 2 : Writeln(Output_file,chr(12)) End; Close(output_file); Show_Mouse; Exit_Gem End.  ANTIC PRESENTS EXPERT OPINION (demo) Copyright 1986 Antic and Mind Soft EXPERT SYSTEMS -- A SMALL HISTORY AND EXPLANATION When we talk about an 'expert,' we mean an individual who is widely recognized as being able to solve a particular type of problem that most other people cannot solve nearly as efficiently. If you are sick, you will most probably go to see a doctor. After several questions and different tests, your doctor makes a diagnosis and presents a treatment. If your car doesn't start you will certainly call the mechanic to make it start. If you have to pay too much income tax, you will probably ask an accountant or a tax counselor for advice. All these experts you are consulting are considered persons who have a large amount of good domain-specific knowledge. As a result of their experience, they may permit us to efficiently solve our problems. Today, there exist computer programs called Expert Systems. These systems are able to behave like human experts in the domains developed for (medical, electronic, financial, etc...) Expert systems are among the first important results of Artificial Intelligence research. Is this the end of the experts? The goal of these programs is not to supplant human experts, but rather to supplement and to multiply them and to extend their capabilities by making their knowledge available for a larger number of persons. Expert systems are composed of a knowledge base that consists of facts and heuristics about a specific domain, of an inference engine that contains the inference procedures and the control strategies and of a base of facts that contains the specifications of a current problem and the results found by the expert system. Expert systems are totally based on knowledge and are characterized by their ease of use and by their possibility to explain how they find a particular result and why they ask a question at a specific moment but also by their capacity to give a well adapted solution on each case. The natural language interface makes expert systems friendly and powerful and allows to modify and to brush up easily the knowledge base. The order of which knowledge is entered into the system does not affect the results. In certain cases, the system may even find results without any precise description of the problem. HOW TO USE THE EXPERT OPINION DEMO MIND SOFT has created an expert system based on the philosophy that anyone should be able to become a "knowledge engineer." Our aim is to provide users with a tool that will solve problems based on choices, diagnosis, identification and, in general, expertise. Demonstration of the ST version. If you have a color monitor, please set it in medium resolution. You should have four files: EXPERT and BASE (main modules), and 2 knowledge base examples (ANIMALS and TVSET). EXPERT This module contains the expert system. Expert Opinion provides 3 modes of inference: - Deduction (forward chaining which goes from facts to conclusions) - Verify hypothesis (backward chaining which starts from a conclusion and goes to facts) - Expertise (forward and backward chaining at the same time) NOTE: This demo is only capable of displaying a 15-rule knowledge base. The real system is capable of a 500 rule base in a 512K system. To give you an idea of how large that is, Stanford University built an expert system called Mycin in the early '80s that diagnosed infectious diseases. That knowledge base had less than 300 rules in it, and it's diagnosis proved to be more accurate in most situations than a real doctors. Expert Opinion is potentially more powerful than Mycin, depending upon the knowledge put into the base. Double click on EXPERT.PRG to run the program. Then select, from the File menu, "Open knowledge base". Open TVSET to activate the knowledge base related to TV breakdowns. Now it is possible to use the three modes. 1) DEDUCTION This mode is to be used when the user is facing a problem for which he can describe what's going wrong. Basically, he should be able to formulate facts (or descriptions). From those formulated facts, Expert Opinion will infer deduction. Example: To formulate facts, select in the Inference Menu: "Add facts", and type 'NO IMAGE' (on the first line). Then click: "OK". Another way to do this is to add facts from a dictionary automatically generated by BASE (the knowledge base manager). This has two advantages: the user may refer to existing words and does not need to use the keyboard (mouse-controlled). For adding facts from dictionary, select, from Inference Menu: "Add facts by dictionary". If the fact to be input is 'THE SCREEN IS ON', you click on 'THE SCREEN' which will appear in the left bottom corner. For the next word, click 'IS' and last 'ON'. The fact 'THE SCREEN IS ON' is then composed. Click: "Store" and "OK". Now it is possible to make a deduction. Select "DEDUCE" in the Inference Menu. 1 new fact will appear. A deduction was thus made. It is now possible to return to the Base of facts (Edit Menu) and ask Expert Opinion how this new fact was deduced. After having selected Base of facts, the base will appear with 3 facts. You may then select the deduced fact by clicking on it (it will appear on last line) and then by clicking 'How ?' Expert Opinion will immediately explain to you how the fact was deduced by referring to a rule (contained in the knowledge base). It is then possible to check the mentioned rule by selecting: "Display a rule" in the Edit Menu. Important: before leaving the deduction mode, don't forget to erase the base of facts by clicking "Empty the base of facts" in Edit Menu. 2) VERIFY HYPOTHESIS To use this mode we will choose another knowledge base. First, close the TVSET base by selecting "Close" in File Menu. Then select: "Open knowledge base" in File Menu and select ANIMALS. Expert Opinion is now ready to answer questions about animals (although in this demo, there are only 15 rules instead of the maximum of 500). This mode is necessary when the user is able to formulate a hypothesis and wants to reach a specified goal. Select: "VERIFY a Hypothesis" in the Inference Menu. Example: type 'the animal is an elephant'. Then click OK. Questions will appear immediatly on the screen. The user may answer by Yes, No or No Idea if he is not able to make up his mind. At this stage it is possible to ask Expert Opinion to explain why he is asking such question. Try it by clicking on "Why?". The program will then justify its line of reasoning. Under the question a 'Why window' will appear with the explanation. 'Level 2' means that Expert Opinion is obliged to go through 1 sub-goal to verify the main goal : 'the animal is an elephant'. The first sub-goal is to prove that the animal is a mammal. If you want to discover the second sub-goal, click "Why?" until you reach level one. Click "OK" to return to the question. According to the user's answers, Expert Opinion will be able to verify (or not) the hypothesis. The system accepts up to 10 sub-goals. Important: a hypothesis must always correspond to the conclusion of a rule and not to one of the conditions composing the rule (see BASE). If you need help, click on Assistance when the system asks to give a hypothesis. 3) EXPERTISE This mode has been designed to allow a user who is not able to formulate facts or build a hypothesis, but wants a solution to his problem. In that case, this mode will do forward and backward chainings. That means that it will raise questions and will also generate new facts whenever possible. Expert Opinion will try to deduce facts based on the answers provided by the user. To operate this mode click Expertise in Inference Menu. A screen will appear with a maximum of 10 classes. In fact, when the expert has created his knowledge base he has been asked to split his knowledge in classes. For instance, a motor can have the following classes: brakes, clutch, electric system, carburator, ignition, etc. In this way, the user might be able to locate his problem in one class to enable Expert Opinion to ask questions related to that specific class of problem in order to avoid the user to have to go through the entire knowledge base. Expert Opinion will only ask questions concerning the rules contained in the class you request (unless you ask to be queried on the entire knowledge base). According to the users answers, Expert Opinion will develop a base of facts that should help the user to solve his problem. 4) BASE This module allows the user to write the rules which compose the base of knowledge. A rule is a proposition containing at least one condition and one conclusion, for instance: 'the animal is a mammal'. All the rules can be split into classes. Each rule can receive a certainty value, which is an indicative coefficient attributed to each rule in order to classify rules between themselves. This classification is interesting when using the inference engine because questions always begin with the highest certainties. The solution is a zone for special comments, warnings and solutions. The first thing to do when creating a knowledge base is to name your base (click "Create a new base" in File Menu). A mask will appear that has to be filled in by the expert. Each time the expert has finished writing one rule he must click Store or Quit. In the demo version of Expert Opinion, the BASE MANAGER is not capable of actually writing a working knowledge base to disk (we have to save something for the product, right?) Take a look through the commands of the Menu Bar and you will see the way the BASE MANAGER works. The Menu Facilities is very handly to provide the user with information concerning the meaning of each command. EXPERT OPINION WILL BE RELEASED MAY 1, 1986. WE INVITE YOU TO... JOIN THE KNOWLEDGE ENGINEERS!  Disk File Functions Page 1 Disk File Operations There may be times when you want to perform operations not supported by the standard Personal Pascal I/O library. Until such time as equivalent routines are added to the Personal Pascal library, you can use direct GEMDOS calls to achieve the results you want. For all calls described in this section, we're going to assume the following TYPE declarations are present in your program: TYPE Path_Chars = PACKED ARRAY [ 1..80 ] OF Char ; Notice that the maximum length of a GEMDOS pathname is 80 characters. The reason we are using a packed array and not a Pascal STRING type is that GEMDOS is expecting path and file names in the "C language" string format. In other words, GEMDOS normally wants a string in which the first byte is the first data character, and it expects the string to be terminated by a zero byte (Chr( 0 ), in Pascal). You can't pass a Pascal STRING to GEMDOS directly, since the first character in a Pascal string (s[0]) is the length byte for the string, and the string is not null-terminated. In order to pass a Pascal string to GEMDOS, you have to copy it into a "C-type" string by calling a procedure like the following: PROCEDURE Make_Path( VAR ps : Str255 ; VAR cs : Path_Chars ) ; VAR i : Integer ; BEGIN FOR i := 1 TO Length( ps ) DO cs[i] := ps[i] ; cs[ length(ps)+1 ] := Chr(0) ; END ; Now that we know what type of names to pass to GEMDOS, we can get on with presenting the calls you can use: Create and open a file. Sometimes, you may want open a file with special properties that Pascal doesn't support. For this purpose, you can use the following routine: FUNCTION f_create( VAR name : Path_Chars ; attributes : Integer ) : Integer ; GEMDOS( $3c ) ; This call creates a new file with the specified name and the specified attributes. The bits in the attributes parameter have the following assignments: bit meaning --- ------- $01 file is read-only $02 file is hidden from directory search $04 file is a system file, hidden from directory search $08 file contains a volume label in the first 8 data bytes The return value is a valid GEMDOS file handle, if greater than or equal to Disk File Functions Page 2 zero, or an error number, if negative. You should use this call to open a file for output, if you want to open a new file, or if you want to first erase the previous contents. If you want to write to an existing file, without erasing the contents, use the f_open call, below. Open a file. You might also want to open an existing file (or one you created with f_create) without using the built-in procedure Reset. You can use this GEMDOS call: FUNCTION f_open( VAR name : Path_Chars ; mode : Integer ) : Integer ; GEMDOS( $3d ) ; Use this call to open a file for reading, writing, or updating. If you want to open a file for writing, but you want to first erase the previous contents, use the f_create call, instead. The valid values for mode are: 0 open for reading only 1 open for writing only 2 open for reading or writing The return value is a GEMDOS handle, if greater than or equal to zero, or an error number, if negative. Notice that this call does not have a parameter to specify the attributes of the file. Those attributes are set by the f_create call and are not changed by this call. If you want to change the attributes of a file, you can use the f_attrib call, below. Close an open file. If you used f_create or f_open to ready a file for access, you should use the following call to close it when you're finished reading or writing to the file: FUNCTION f_close( handle : Integer ) : Integer ; GEMDOS( $3e ) ; The parameter handle should be the same as that returned by the appropriate open call. Zero is returned, if the file was closed successfully, or a negative error number, otherwise. Read bytes from a file. Pascal supports reading from and writing to files one item at a time, where the size of the item is the size of the file pointer variable. Occasionally you may want to read or write in larger chunks, especially if your item size is small, since GEMDOS isn't very fast for single-byte transfers. The following call allows you to read a block of characters into memory: FUNCTION f_read( handle : Integer ; count : Long_Integer ; VAR buf : Buf_Type ) : Long_Integer ; GEMDOS( $3f ) ; This call reads an arbitrary number of bytes from a file into a desired Disk File Functions Page 3 buffer. The number of bytes actually read is returned, if the function was successful, or a negative error number, if something went wrong. Note that the number of bytes actually read may be shorter than the number of bytes requested, if the end-of-file position was reached. The Buf_Type mentioned above may be almost any type. For example, to read 100 two-byte values into an array, you might use a program segment like this: TYPE Hundred_Integers = ARRAY [ 1..100 ] OF Integer ; VAR a : Hundred_Integers ; bytes_read : Long_Integer ; PROCEDURE f_read( handle : Integer ; count : Long_Integer ; VAR buf : Hundred_Integers ) : Long_Integer ; GEMDOS( $3f ) ; BEGIN bytes_read := f_read( handle, 200, a ) ; END ; Note that 200 was passed as the number of bytes to read, since we wanted 100 two-byte values! The handle parameter should be that value returned by either the f_create or f_open call. If you want to use the f_read call to read from a file which was opened using the built-in procedure Reset, you can use the function Handle to find out the handle associated with the file. If you are reading from a file just opened using Reset, you must be aware, however, that the first item has already been read from the file and put into the file buffer variable. Write bytes to a file. Similarly, you may want to write an arbitrary number of bytes to a file. The following call supports block writing: FUNCTION f_write( handle : Integer ; count : Long_Integer ; VAR buf : Buf_Type ) : Long_Integer ; GEMDOS( $40 ) ; This call is the counterpart of the f_read function described above. It takes an arbitrary number of bytes from a buffer and outputs them to a previously opened file. The handle parameter must be that which was returned by a previous f_open or f_create call. You can also use the Handle function to get the handle of a file which was opened using the Rewrite built-in procedure. The value returned by f_write is the number of bytes written, if the operation was successful, or a negative error number. In general, if the number of bytes returned does not equal the number requested, something went wrong! Delete a file. There is no standard procedure in Pascal to remove a file from a disk, so if you want to erase files, you need the following call: FUNCTION f_delete( VAR name : Path_Chars ) : Integer ; GEMDOS( $41 ) ; Disk File Functions Page 4 Zero is returned, if the delete was successful, or a negative error value, otherwise. Seek within a file. Personal Pascal supports random access to files using the built-in procedures Get, Put, and Seek. If you want to use instead the underlying GEMDOS routine to position within a file, here it is: FUNCTION f_seek( offset : Long_Integer ; handle, mode : Integer ) : Long_Integer ; GEMDOS( $42 ) ; Use this call to point to a particular byte position within a file. The offset parameter specifies the desired byte position, and the mode parameter specifies which file position the offset parameter is relative to: mode relative to ---- ----------- 0 the beginning of the file 1 the current location 2 the end of the file The offset parameter is signed, so you could, for example, move 10 bytes backwards in the file by specifying offset and mode parameters of -10 and 1, respectively. Get/Set file attributes. As mentioned above, the f_create call sets a file's attributes. These attributes are never changed when the file is subsequently opened. If you ever want to change the attributes of a file, you should use the following call: FUNCTION f_attrib( VAR name : Path_Chars ; mode, attributes : Integer ) : Integer ; GEMDOS( $43 ) ; The mode parameter specifies whether to get the file attributes, if 0, or to set the attributes, if 1. The attributes parameter is specified in the same way as for the f_create call, above, with the following two additions: bit meaning --- ------- $10 file is a subdirectory $20 file is written and closed correctly. These two attributes only refer to subdirectories. (* gembox.pas - Grow-, shrink-, drag-, and rubber-box calls. *) (*$M+,E+,R-*) PROGRAM Gem_Box ; CONST (*$I gemconst.pas*) TYPE (*$I gemtype.pas*) (*$I gemhtype.pas*) (*$I gemhdr.pas*) (*$E-*)(* Next routine is private! *) PROCEDURE Box_Cmd( cmd, i1, i2, i3, i4, i5, i6, i7, i8 : integer ; VAR out1, out2 : integer ) ; VAR int_in : Int_In_Parms ; int_out : Int_Out_Parms ; addr_in : Addr_In_Parms ; addr_out : Addr_Out_Parms ; BEGIN int_in[0] := i1 ; int_in[1] := i2 ; int_in[2] := i3 ; int_in[3] := i4 ; int_in[4] := i5 ; int_in[5] := i6 ; int_in[6] := i7 ; int_in[7] := i8 ; AES_Call( cmd, int_in, int_out, addr_in, addr_out ) ; out1 := int_out[1] ; out2 := int_out[2] ; END ; (*$E+*)(* Back to public routines! *) PROCEDURE Rubber_Box( x, y, min_w, min_h : integer ; VAR w, h : integer ) ; BEGIN Box_Cmd( 70, x, y, min_w, min_h, 0, 0, 0, 0, w, h ) ; END ; PROCEDURE Drag_Box( w, h, x0, y0, x_max, y_max, w_max, h_max : integer ; VAR x, y : integer ) ; BEGIN Box_Cmd( 71, w, h, x0, y0, x_max, y_max, w_max, h_max, x, y ) ; END ; (*$E-*)(* Another private routine! *) PROCEDURE Grow_Shrink( cmd, small_x, small_y, small_w, small_h, big_x, big_y, big_w, big_h : integer ) ; VAR int_in : Int_In_Parms ; int_out : Int_Out_Parms ; addr_in : Addr_In_Parms ; addr_out : Addr_Out_Parms ; BEGIN int_in[0] := small_x ; int_in[1] := small_y ; int_in[2] := small_w ; int_in[3] := small_h ; int_in[4] := big_x ; int_in[5] := big_y ; int_in[6] := big_w ; int_in[7] := big_h ; AES_Call( cmd, int_in, int_out, addr_in, addr_out ) ; END ; (*$E+*)(* Back to the public routines! *) PROCEDURE Grow_Box( small_x, small_y, small_w, small_h, big_x, big_y, big_w, big_h : integer ) ; BEGIN Grow_Shrink( 73, small_x, small_y, small_w, small_h, big_x, big_y, big_w, big_h ) ; END ; PROCEDURE Shrink_Box( big_x, big_y, big_w, big_h, small_x, small_y, small_w, small_h : integer ) ; BEGIN Grow_Shrink( 74, small_x, small_y, small_w, small_h, big_x, big_y, big_w, big_h ) ; END ; PROCEDURE Move_Box( w, h, x, y, new_x, new_y : integer ) ; BEGIN Grow_Shrink( 72, w, h, x, y, new_x, new_y, 0, 0 ) ; END ; BEGIN END. (* End of gembox.pas *)  FIGURE 5.2 (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* *) (* STRAIGHT INSERTION SORT -- PICK AN ITEM AND, MOVING *) (* TOWARD THE LOW END OF THE ARRAY, FIND *) (* WHERE IT SHOULD BE INSERTED. PICK THE *) (* NEXT ITEM AND CONTINUE UNTIL THE WHOLE *) (* ARRAY IS SORTED. USES A SENTINEL IN *) (* THE ZERO ARRAY POSITION. *) (* *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE SORT (VAR DATA: DATA_ARRAY; COUNT: INTEGER); VAR I, J: INTEGER; (* LOOP INDICES *) ITEM: INTEGER; (* THE ITEM WHOSE POSITION IS *) (* BEING SOUGHT *) BEGIN (* STRAIGHT INSERTION SORT *) FOR I := 2 TO COUNT DO BEGIN ITEM := DATA[I]; DATA[0] := ITEM; (* SET THE SENTINEL *) J := I - 1; WHILE ITEM < DATA[J] DO (* MOVE THE HOLE, WHERE *) BEGIN (* ITEM WAS, DOWN WHERE *) DATA[J+1] := DATA[J]; (* IT SHOULD BE, PUT *) J := J - 1 (* ITEM IN IT. *) END; DATA[J+1] := ITEM; WRITELN (SORT_TABLE,'PASS #',I-1:1,' ITEM = ',ITEM:1); PRINT_ARRAY(DATA,COUNT) END END; (* STRAIGHT INSERTION SORT )* PROGRAM SORT_DRIVER(INPUT,OUTPUT,SORT_DAT,SORT_TABLE); (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* SORT ALGORITHM DEMONSTRATION PROGRAM *) (* PROGRAMMER: CHRIS ROBERTSON *) (* ST APPLICATIIONS DEMO *) (* *) (* DESCRIPTION: THIS PROGRAM IS DESIGNED TO BE A DRIVVER *) (* PROGRAM FOR DEMONSTRATION VARIOUS SORTING ALGORITHMS. *) (* IT READS A TEXT FILE OF INTEGERS INTO AN ARRAY AND THEN *) (* PASSES THE ARRAY TO A USER-SUPPLIED SORT ROUTINE. *) (* THE PROCEDURE PRINTARY MAY BE USED BY THE SORT ROUTINE. *) (* TO PRINT THE CURRENT CONTENTS OF THE ARRAY AT VARIOUS *) (* POINTS IN THE SORTING PROCESS, SO TO FURTHER YOUR UNDER- *) (* STANDING OF SORTING. *) (* YOU CAN PRINT THE SORT TABLE THROUGH GEM. VERSION 1.0 *) (**************************************************************) CONST MAX_ARRAY = 100; DISKA1 = 'A:SORT_DAT'; DISKA2 = 'A:SORT_TABLE'; TYPE DATA_ARRAY = ARRAY[0..MAX_ARRAY] OF INTEGER; VAR DATA: DATA_ARRAY; (* DATA ARRAY PASSED TO USER *) I, (* ROUTINE FOR SORTING *) COUNT: INTEGER; (* NUMBER OF INTEGERS IN DATA*) SORT_DAT, SORT_TABLE:TEXT; (* TEXTFILES, ONE WITH DATA, *) (* THE OTHER WITH OUTPUT *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* READ_ARRAY -- READ THE CONTENTS OF THE DATA FILE INTO *) (* THE DATA ARRAYPREPARATORY TO SORTING. *) (* NOTE: IT IS ASSUMED THAT THE DATA IS AN *) (* INDEFINITE NUMBER OF INTEGERS (NOP MORE THAN *) (* MAXARY) STORED ONE PER LINE ON THE DATA FILE *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE READ_ARRAY(VAR DATA:DATA_ARRAY; VAR COUNT:INTEGER); BEGIN (* READ_ARRAY *) RESET(SORT_DAT,DISKA1); COUNT := 0; WHILE NOT EOF(SORT_DAT) AND (COUNT <= MAX_ARRAY) DO BEGIN COUNT := COUNT + 1; READLN(SORT_DAT,DATA[COUNT]) END END; (* READ *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* *) (* PRINT_ARRAY--PRINTS THE CONTENTS OF THE ARRAY SO THAT *) (* THE SORTING PROCESS MAY BE FOLLOWED *) (* *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE PRINT_ARRAY(VAR DATA:DATA_ARRAY; COUNT:INTEGER); CONST PERLINE = 8; (* NUMBER OF DATA VALUES PRINTED *) PLACES = 8; (* ON EACH LINE *) VAR I: INTEGER; BEGIN FOR I := 1 TO COUNT DO IF (I MOD PERLINE = 0) THEN WRITELN(SORT_TABLE,DATA[I]:PLACES) ELSE WRITE(SORT_TABLE,DATA[I]:PLACES); WRITELN END; (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* *) (* STRAIGHT INSERTION SORT -- PICK AN ITEM AND, MOVING *) (* TOWARD THE LOW END OF THE ARRAY, FIND *) (* WHERE IT SHOULD BE INSERTED. PICK THE *) (* NEXT ITEM AND CONTINUE UNTIL THE WHOLE *) (* ARRAY IS SORTED. USES A SENTINEL IN *) (* THE ZERO ARRAY POSITION. *) (* *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE SORT (VAR DATA: DATA_ARRAY; COUNT: INTEGER); VAR I, J: INTEGER; (* LOOP INDICES *) ITEM: INTEGER; (* THE ITEM WHOSE POSITION IS *) (* BEING SOUGHT *) BEGIN (* STRAIGHT INSERTION SORT *) FOR I := 2 TO COUNT DO BEGIN ITEM := DATA[I]; DATA[0] := ITEM; (* SET THE SENTINEL *) J := I - 1; WHILE ITEM < DATA[J] DO (* MOVE THE HOLE, WHERE *) BEGIN (* ITEM WAS, DOWN WHERE *) DATA[J+1] := DATA[J]; (* IT SHOULD BE, PUT *) J := J - 1 (* ITEM IN IT. *) END; DATA[J+1] := ITEM; WRITELN (SORT_TABLE,'PASS #',I-1:1,' ITEM = ',ITEM:1); PRINT_ARRAY(DATA,COUNT) END END; (* STRAIGHT INSERTION SORT )* (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* MAIN PROGRAM--THE USER'S SORT ROUTINE SHOULD BE DECLARED*) (* AS: SORT(VAR DATA: DATA_ARRAY; COUNT:INTEGER); WHERE *) (* DESIRED IT MAY CALL PRINT_ARRAY(DATA,COUNT); *) (* TO PRINT OUT THE CURRENT STATE OF THE ARRAY BEING SORTED*) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) BEGIN (* MAIN *) REWRITE(SORT_TABLE,DISKA2); WRITELN(SORT_TABLE,'INSERTION SORT'); WRITELN(SORT_TABLE); READ_ARRAY(DATA,COUNT); WRITELN(SORT_TABLE,'INITIAL STATE OF THE ARRAY'); PRINT_ARRAY(DATA,COUNT); SORT(DATA,COUNT); WRITELN(SORT_TABLE); WRITELN(SORT_TABLE,'END OF ARRAY DRIVER PROGRAM'); FOR I := 1 TO 26 DO WRITELN; WRITELN(' <<>>'); WRITELN(' >>> DATA WILL BE ON FILE SORT_TAB<<<'); WRITELN(' <<<<<>>>>'); FOR I := 1 TO 13 DO WRITELN; END. (* SORT DRIVER PROGRAM *) FIGURE 5.3 INSERTION SORT INITIAL STATE OF THE ARRAY 44 55 12 42 94 10 6 67 PASS #1 ITEM = 55 44 55 12 42 94 10 6 67 PASS #2 ITEM = 12 12 44 55 42 94 10 6 67 PASS #3 ITEM = 42 12 42 44 55 94 10 6 67 PASS #4 ITEM = 94 12 42 44 55 94 10 6 67 PASS #5 ITEM = 10 10 12 42 44 55 94 6 67 PASS #6 ITEM = 6 6 10 12 42 44 55 94 67 PASS #7 ITEM = 67 6 10 12 42 44 55 67 94 END OF ARRAY DRIVER PROGRAM `6 o"h## #$Bb3(NfN:READ_ARRAY?Hz~*/,HNVNA-HPHy Hz?< N.~+"nBQ~,~,09F@"n2tdB_C@dD~-~."n$n0R@2~/Hy "n$n0Ad@/ N N X~0~1`N^,_X> _PNA:SORT_DATPRINT_ARRA?Hz~A/,HNVNA-HPp=@=n0.nnv~B~B0.rHH@J@f4~CHy\"n0.Ad@??<N N 0X~D`(~DHy\"n0.Ad@??<N XRn`~E~FHyN 0XN^,_X> _\NSORT ?Hz~\/,HNVNA*-HPp=@=n0.nn ~]~]~^"n0.Ad@=Q~_"n2~`0.S@=@~a~a0."n2.CdAQl:~b~c"n0.R@Ad@$n0.Ad@2~d0.~eS@=@`~f"n0.R@Ad@2~gHy\Hzv?<N 0.S@??<N HzN?<N ?.?<N N 0X~h"n/ ?.~iN~j~kRn`N^,_X> _\N ITEM = PASS #A.0B1|A01|A\01|A 01|~tA#*Hy\Hz?< N6~uHy\Hzl?<N N 0X~vHy\N 0X~wHyHyXNf~xHy\Hz?<N N 0X~yHy?9XN~zHy?9XN~{Hy\N 0X~|Hy\Hz?<N N 0X~}p3Z yZn~~~~HyN 0XRyZ`~HyHz ?<5N N 0X><HyHz?<2N N 0X><HyHzx?<5N N 0X><p3Z y Zn ><><HyN 0XRyZ`><Hy NHy\NHyNN <<<<<>>>> >>> DATA WILL BE ON FILE SORT_TAB<<< <<>>END OF ARRAY DRIVER PROGRAMINITIAL STATE OF THE ARRAYINSERTION SORTA:SORT_TABLEB9`PBy _0g$_jp"_// HNLJ@fP)J9f" f |` f|` f |` f|`4<G BQB) @ef *:f^&Jrt `e QGbtWJBk4Gz3 J9f g g`> g8 fp@`*S@rG   e gRAQJ9g`tJ)f8a J9g| _0< HyN||#|3|Nu )bJ) g )g )g ) f J9fgHBNu|/ BgHi ?<ANA>3|NAXNu _4` _t6 Bo r aSB`2aNH? * _r ar a/L? *Nu _r aN _4` _t"x0HgJJjDxvC jzp cRЀ`|e W0R"f`6 _4` _t2xJAjDAxvC jp0 2H@0RJAfJg<-RBlCSBr aQSCaQN _4v` _46"_JBjtClBSCr aQSBk aQN _v` _60@d C t`C tClBSCr aQSBavQNFALSETRUE _6kfv2_t Cc"4YBv` _6kfv"_t Cc4QBvSBkr a(QSCC" A0 9c^a JgYC`NH "oA/ N jL NuBy(_ _/ C( g  f,t4(H / /?(?<@NA LJkffNu4(SBraQNu(gN fH ??<NAXLNu f H ??<` f H ??<` f NuHy U` Hy .0< LN|REWRITE required prior to WRITE or PUTDisk or directory fullBy _$_"Wp )f)H/ NL4NH/ NLp)`By _"WJyf8J)f )f)H/ NL )g)J)fJgBy )g J)fBiNz`zBy _$_"WptvH/ Hya029XL- -fJf^p`4  fJg*`N0eH  bBԂi\(؄iV؄iRԄiNԁRCJ)f  g )f) 0e 9c~Jg&JgDJf 6Höf4N$NHy0<` Hy0<N|By _$_0"Wt )gJ&JRJ)f4H/ HyaP29XL )gJ)f RBBe`ưBe`N&|H/ ?< NA\Hy?< NA\LS@kQ3N Bad digit in number encounteredOverflow during READ of numberBy(_ _/ C (g ( fxJ(f t4($IH / /?(?<?NA LJk,g*fJg  f"J` g  Wf NuJgJ(f P Nu!|Nu4(SBa@J(f8Jg. fJ(f"gr W1Agp f W1A1AQNu(gVJ(fD f&H`?<NAT f?< ?<NAXp LNu fH`?<NATLNuHyD0<` Hy 0< LN|Reset required prior to Read or GetAttempt to read past end-of-file~,GxvGI/??<NM(PRDQNuHy@?< NA\xvI/??<NMPRDQBgNAHy`Hy `Hy$?< NA\HyHy`Hy?< NA\Hy?< NA\ oa.Hy. n` n,n/HyP?< NA\ _`/?<$?<NAX _tv"0 :e^H ??<NAXLYCQNu. *** Bus error *** Address error - attempt to reference address *** Attempt to divide by zero *** Value out of range *** Integer overflow *** Error in Called by PROCEDURE FUNCTION MAIN PROGRAM at source line at PC function or procedure compiled w/o DEBUG _ hNVf 0(gr"OD@Hd2S@k "Q` _"ye HyNNN## .f -|>`-|> nNнf yNStack overruns heap _(N _0/Ho |b3JyfXNX/#"|a "_a"|aJy(g y9BgNA/ ?< NA\Nu09Nu _3NByNu *** *** Copyright 1986, CCD and OSS, Inc. 0@B0B             HB@6 2J X D   ( 0"L2 T  0 DO BEGIN (* Get the next digit value. If the digit is not zero, or the digit will not be the leading digit, then add it to the string (this inhibits the addition of leading zeros). *) digit := n DIV divisor; IF (digit <> 0) OR NOT( leading ) THEN BEGIN add_char( chr(digit + ord('0')) ); leading := false; END; (* Throw away the part of the number just used, and decrease the divisor so we will get the next digit next time. *) n := n MOD divisor; divisor := divisor DIV 10; END; (* At this point, if the index is still zero, then we didn't add any characters to the string! The original number must have been zero, so just add that single character. *) IF i = 0 THEN add_char( '0' ); (* Finally, set the length of the string to the final index value. *) s[0] := chr(i); END; (* val - Convert the number contained in the string 's' to an integer, and return that integer as the function result. We are assuming the caller has ensured the string is a valid number, so we we're just going to convert characters into the number until a non-digit is encountered, or the end of the string is reached. A zero is returned as the function value if the string that was passed has zero length. *) FUNCTION val( s: str255 ): integer; VAR (* Flag to indicate the number has a leading minus sign *) minus: boolean; BEGIN (* Start with the first character of the string, but first skip leading blanks. *) i := 1; WHILE (i < length(s)) AND (s[i] = ' ') DO i := i + 1; (* If there are characters still in the string, convert it to a number *) n := 0; IF length(s) >= i THEN BEGIN (* If first char is '-', we have to negate the number after we finish converting the digits. *) IF s[i] <> '-' THEN minus := false ELSE BEGIN minus := true; i := i + 1; END; (* While there are more digits in the string, convert characters. *) WHILE (i <= length(s)) AND (s[i] IN ['0'..'9']) DO BEGIN n := (n * 10) + ord(s[i]) - ord('0'); i := i + 1; END; (* Negate the final result, if necessary. *) IF minus THEN n := -n; END; (* Return the converted number as the result of this function. *) val := n; END; BEGIN FOR i := -10 TO 10 DO BEGIN readln( s ); n := val(s); write( n, ' = ' ); str( n, s ); writeln( s ); END; END. GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGPROGRAM Madlibs( Input, Output ); { Todd Krissel - 04/17/86 Note: This could be a lot better... maybe loading in data files for different ver- sions of "Madlibs," but what do you want for nothing? } CONST num_nouns = 4; num_verbs = 2; num_adjectives = 6; num_adverbs = 2; num_names = 2; num_places = 1; VAR play : Boolean; ch : Char; nouns : Array[1..num_nouns] OF String; verbs : Array[1..num_verbs] OF String; adverbs : Array[1..num_adverbs] OF String; adjectives : Array[1..num_adjectives] OF String; names : Array[1..num_names] OF String; places : Array[1..num_places] OF String; PROCEDURE Title; { print out the title page } VAR i : Integer; ch : Char; BEGIN { Title } Write( Chr(27), 'E' ); { clear the screen } Write( Chr(27), 'f' ); { disable cursor } FOR i := 1 TO 6 DO Writeln; Writeln( '*** MADLIBS! ***':48 ); Writeln; Writeln; Write( ' Here''s your chance to become' ); Writeln( ' a world famous author! Just supply' ); Write( ' the program with the proper word ' ); Writeln( 'type: noun, verb, adjective, adverb,' ); Write( ' a person''s name, or a location.' ); Writeln( ' Leave the rest of the fun to MADLIBS!' ); FOR i := 1 TO 6 DO Writeln; Write( 'Press any key to continue.':52 ); Read( ch ); Writeln( Chr(27), 'e' ); { enable cursor } END; { Title } PROCEDURE Get_words; { get all story words } VAR i : Integer; BEGIN {Get_words} Write( Chr(27), 'E' ); { clear the screen } Writeln; FOR i := 1 TO num_nouns DO BEGIN { noun input } Write( ' Enter a noun, press '); Write( '[Return] when done. ==>' ); Readln( nouns[i] ) END; { noun input } Writeln; FOR i := 1 TO num_verbs DO BEGIN {verb input} Write( ' Enter a verb, press '); Write( '[Return] when done. ==>' ); Readln( verbs[i] ) END; { verb input } Writeln; FOR i := 1 TO num_adjectives DO BEGIN { advective input } Write( ' Enter an adjective, press ' ); Write( '[Return] when done. ==>' ); Readln( adjectives[i] ) END; { adjective input } Writeln; FOR i := 1 TO num_adverbs DO BEGIN { adverb input } Write( ' Enter an adverb, press ' ); Write( '[Return] when done. ==>' ); Readln( adverbs[i] ) END; { adverb input } Writeln; FOR i := 1 TO num_names DO BEGIN { names input } Write( ' Enter a person''s name, press ' ); Write( '[Return] when done. ==>' ); Readln( names[i] ) END; { names input } Writeln; FOR i := 1 TO num_places DO BEGIN { places input } Write( ' Enter a location, press ' ); Write( '[Return] when done. ==>' ); Readln( places[i] ) END { places input } END; { Get_words } PROCEDURE Show_story; { display story with entered words } VAR i, sp : Integer; BEGIN { Show_story } Write( Chr(27), 'E' ); { clear the screen } Writeln; Writeln( ' Here''s your story...' ); Writeln; Writeln; BEGIN { printing the story } sp := ( 80 - ( 13 + Length( places[1] ) ) ) DIV 2 + 13; { center name } Writeln( 'Adventure in ':sp, places[1] ); Writeln; Writeln( 'by':41 ); sp := Length( names[1] ) + ( 80 - Length( names[1] ) ) DIV 2; { center name } Writeln( names[1]:sp ); Writeln; Write( ' Here I sit, alone in my ' ); Writeln( 'motel room with only my ', nouns[1] ); Write( ' for company. Suddenly, there is a very '); Writeln( adjectives[1], ' knock at my door.' ); Write( ' "Who is it?" I asked. A crazed, ' ); Writeln( adjectives[2],' voice cries ', adverbs[1], ',' ); Write( ' "Hey, it''s your ', adjectives[3], ', ' ); Writeln( adjectives[4], ' ', nouns[2], ', you' ); Write( ' ', adjectives[5], ' ', nouns[3], '." ' ); Writeln( 'Of course, I know it can be no one but' ); Write( ' ', names[2], ', the only human ' ); Writeln( nouns[3], ' in ', places[1], '. I' ); Write( ' attempt to ', verbs[1], ', but '); Writeln( 'it doesn''t help. ', names[2] ); Write( ' continues to ', verbs[2], ' near' ); Writeln( ' my ', nouns[4], '. I fall asleep' ); Write( ' ', adverbs[2], ', a little bit ' ); Writeln( adjectives[6], '.' ); END; { printing the story } FOR i := 1 TO 4 DO { clean up display } Writeln END; { Show_story } BEGIN { Madlibs } Title; play := True; REPEAT BEGIN { main loop } Get_words; Show_story; Write( 'Would you like to play another game?':58 ); Read(ch); IF ( ch = 'N' ) OR ( ch = 'n' ) THEN play := FALSE ELSE play := TRUE; Writeln END; { main loop } UNTIL play = FALSE; Write( 'Thank you for playing MADLIBS! Press any key to exit.':67 ); Read( ch ) END. { Madlibs } ````````````````````````````````PROGRAM MORTGAGE(INPUT,OUTPUT,TABLE,SLIPS); (*********************************************************) (* THE HOME MORTGAGE PROGRAM *) (* *) (* PROGRAMER: CHRISTOPHER ROBERTSON *) (* ST APPLICATIONS DEMO VER. 1.0 *) (* *) (* DATE: 1/1/86 *) (* COMPILED WITH PERSONAL PASCAL FROM O.S.S. *) (* *) (* THE MORTGAGE PROGRAM, GIVEN 1) THE % OF THE MORTGAGE *) (* 2) THE AMOUNT OF THE MORTGAGE 3) DURATION OF THE *) (* MORTGAGE IN YEARS 4) THE NUMBER OF PAYMENT PERIODS *) (* PER YEAR, WILL WRITE TWO FILES. ONE A LOAN TABLE FOR*) (* THE CLIENT, THE OTHER PAYMENT SLIPS. THE FILES CAN *) (* THEN BE PRINTED TO SCREEN OR THE PRINTER,VIA GEM. *) (*********************************************************) CONST DISK1 = 'A:TABLE'; (* EXTERNAL DEVICE ASSIGNMENTS *) DISK1A = 'A:SLIPS'; VAR ALLPERIODS, (* TOTAL NUMBER OF PAYMENTS IN LOAN *) YEARS, (* DURATION OF LOAN IN YEARS *) PERIODS, (* PERIODS PER YEAR *) HPERIOD, PERIODNUM : INTEGER; MORGAMOUNT, (* AMOUNT OF THE LOAN *) INTRESTAMOUNT, (* THE INTREST FOR THE LOAN IN % *) INTREST, PAYMENT, (* MONTHLY PAYMENT *) PAY, PAY1, (* PAY AND PAY1 ARE USED TO CALCULATE PAYMENT *) TOWARDPRINCIPAL, AJUSTBALANCE, PAYSOFAR, CUMINTREST, AJUSTED, PRINCIPALSOFAR, LESSPRINCIPAL, PI, (* PI AND PIR ARE USED *) PIR :REAL; (* FOR PIRODIC INTREST RATE *) TABLE, SLIPS: TEXT; (* EXTERNAL TEXT FILES TO BE WRITTEN *) (**********************************************************) (* FUNCTION FOR EXPONENT, USING PERSONAL PASCALS MATH *) (* EXPRESSIONS, WE ARE ABLE TO SHOW USE OF A FUNCTION *) (**********************************************************) FUNCTION POWER(NUM:REAL;POW:INTEGER):REAL; BEGIN (* POWER *) POWER:=EXP(LN(NUM) * POW) END; (* POWER *) (*************************************************************) (* HERE WE INITALIZE OUR VARIBLES, WE COULD HAVE PERSONAL *) (* PASCAL DO IT FOR US BUT FOR PRACTICE WE SHOULD KNOW THAT *) (* THE VARIBLES NEED TO BE INITIALIZED. *) (*************************************************************) PROCEDURE INITIALIZE; BEGIN (* INITIALIZE *) (* INITIALIZING VARIBLES *) YEARS := 0; PERIODS := 0; PERIODNUM := 0; MORGAMOUNT := 0.0; INTRESTAMOUNT := 0.0; INTREST := 0.0; PAYMENT := 0.0; PAY := 0.0; PAY1 := 0.0; PRINCIPALSOFAR := 0.0; TOWARDPRINCIPAL := 0.0; AJUSTED := 0.0; PAYSOFAR := 0.0; CUMINTREST := 0.0; LESSPRINCIPAL := 0.0; PI := 0.0; PIR := 0.0 END; (* INITIALIZE *) (*****************************************************) (* IN THIS PART OF THE PROGRAM WE COMMUNICATE TO THE *) (* USER, AND GAIN INFO FOR PROCCESSING *) (*****************************************************) PROCEDURE DOCUMENT; VAR I : INTEGER; DUMMY : CHAR; BEGIN (* DOCUMENT *) FOR I := 1 TO 26 DO WRITELN; WRITELN('THIS PROGRAM WILL CALCULATE MORTGAGE PAYMENTS'); WRITELN('FOR YOU WHEN YOU SUPPLY THE FOLLOWING LOAN INFORMATION:'); WRITELN; WRITELN('ENTER THE INTREST RATE IN PERCENT (%)'); READLN(INTRESTAMOUNT); WRITELN('ENTER THE FULL AMOUNT OF THE MORTGAGE INCLUDING CENTS'); READLN(MORGAMOUNT); WRITELN('ENTER THE DURATION OF THE LOAN IN YEARS'); READLN(YEARS); WRITELN('ENTER THE NUMBER OF PAYMENT PERIODS PER YEAR'); READLN(PERIODS); ALLPERIODS := PERIODS * YEARS; HPERIOD := ALLPERIODS; AJUSTBALANCE := MORGAMOUNT; WRITELN('INSERT A BLANK FORMATTED DISK INTO DRIVE A:'); WRITELN('AND THEN HIT RETURN'); READ(DUMMY); FOR I := 1 TO 26 DO WRITELN; WRITE (' <<<<<<<<<<*** '); WRITELN('PROCCESSING DATA & WRITTING TO DISK***>>>>>>>>>'); WRITE (' <<<<<<<<<<*** '); WRITELN('PLEASE ALLOW SEVERAL MINUTES***>>>>>>>>>>'); WRITELN(' BELL WILL SOUND'); FOR I := 1 TO 13 DO WRITELN END; (* DOCUMENT *) (*************************************************************) (* IN PRACTICE THIS PROCEDURE COULD BE BROKEN DOWN TO A FEW *) (* SMALLER SUB PROCEDURES, I HAVE LEFT THAT AS AN EXERCISE *) (* TO GIVE YOU A CHANCE AT MODIFING THIS PROGRAM FOR YOURSELF*) (*************************************************************) PROCEDURE PROCCESS_INFO; BEGIN (* PROCCESS *) REWRITE(TABLE,DISK1); WRITELN(TABLE,'THE MORTGAGE IS FOR $',MORGAMOUNT:10:2); WRITELN(TABLE,'YOU HAVE ',YEARS:2,' YEARS TO PAY IT OFF'); WRITELN(TABLE,PERIODS,' PERIODS PER YEAR'); WRITELN(TABLE,'AT AN INTREST RATE OF % ',INTRESTAMOUNT:10:2); WRITELN(TABLE); WRITE(TABLE,'PERIOD # PAYMENT FOR INTREST '); WRITELN(TABLE,' FOR PRINCIPAL BALANCE'); WRITE(TABLE,'************************************'); WRITELN(TABLE,'**********************************'); REWRITE(SLIPS,DISK1A); WRITELN(SLIPS,'YOUR MORTGAGE IS WORTH $ ',MORGAMOUNT:10:2); WRITELN (SLIPS,'THE INTREST WILL BE SET AT ',INTRESTAMOUNT:10:2,'%'); WRITELN(SLIPS,'YOU WILL HAVE ',YEARS:1,' YEARS , TO PAY THE LOAN'); WRITE(SLIPS,'YOU MUST MAKE ',ALLPERIODS:1,' PAYMENTS'); WRITELN(SLIPS,' DURING MORTGAGE DURATION'); WRITELN(SLIPS,'THE PAYMENTS BREAK DOWN AS FOLLOWS:'); WRITELN(SLIPS); WRITELN(SLIPS); PERIODNUM := 1; WHILE ALLPERIODS >= PERIODNUM DO (* START OF PRINT LOOP*) BEGIN PI := INTRESTAMOUNT/PERIODS; PIR := PI/100; PAY := MORGAMOUNT * PIR; (* MONTHLY PAYMENT IS FIGURED *) PAY1 := 1 + PIR; PAY1 := POWER(PAY1,ALLPERIODS); PAY1 := 1 - 1 / PAY1; PAYMENT := PAY / PAY1; PAYMENT :=LONG_ROUND(PAYMENT * 100)/100; (* PROCESS THE VARIBLES *) HPERIOD := HPERIOD - 1; (* FOR EACH PERIOD *) INTREST := PIR * AJUSTBALANCE; INTREST :=LONG_ROUND(INTREST * 100)/100; TOWARDPRINCIPAL := PAYMENT - INTREST; PRINCIPALSOFAR := PRINCIPALSOFAR + TOWARDPRINCIPAL; AJUSTBALANCE := MORGAMOUNT - PRINCIPALSOFAR; PAYSOFAR := PAYSOFAR + PAYMENT; CUMINTREST := CUMINTREST + INTREST; AJUSTED:= AJUSTED + AJUSTBALANCE; LESSPRINCIPAL := MORGAMOUNT - AJUSTBALANCE; IF ALLPERIODS = PERIODNUM THEN (* TESTS FOR AND AJUSTS *) BEGIN (* LAST PAYMENT *) PAYMENT := AJUSTBALANCE + PAYMENT; AJUSTBALANCE := 0.0; END; (* OUTPUT FORMAT FOR TABLE *) WRITE(TABLE,PERIODNUM:8); WRITE(TABLE,'$':4,PAYMENT:10:2); WRITE(TABLE,'$':4,INTREST:10:2); WRITE(TABLE,'$':8,TOWARDPRINCIPAOL:10:2); WRITELN(TABLE,'$':8,AJUSTBALANCE:10:2); WRITELN(TABLE); (* OUTPUT FORMAT FOR PAYMENT SLIPS *) WRITELN(SLIPS,'*******************************************************'); WRITELN(SLIPS,' MORTGAGE PAYMENTS '); WRITELN(SLIPS,'-------------------------------------------------------'); WRITELN(SLIPS,'PERIOD # ',PERIODNUM:1,' ',HPERIOD:1,' PAYMENT(S) LEFT '); WRITELN(SLIPS,'-------------------------------------------------------'); WRITELN(SLIPS,'PAYMENT NOW DUE $ ',PAYMENT:10:2); WRITELN(SLIPS); WRITELN(SLIPS,'INTEREST AMOUNT ON PRINCIPAL AJUSTED BALANCE'); WRITELN(SLIPS,'======== =================== ==============='); WRITE (SLIPS,'$':1,INTREST:10:2,'$':6,TOWARDPRINCIPAL:12:2,'$':12); WRITELN(SLIPS,AJUSTBALANCE:9:2); WRITELN(SLIPS,'-------------------------------------------------------'); WRITELN(SLIPS,'TOTAL PAYMENTS SO FAR $ ',PAYSOFAR:10:2); WRITELN(SLIPS,'TOTAL INTREST PAID $ ',CUMINTREST:10:2); WRITELN(SLIPS,'PRINCIPAL PAID SO FAR $ ',LESSPRINCIPAL:10:2); WRITELN(SLIPS,'*******************************************************'); PERIODNUM := PERIODNUM + 1 END (* OF THE WHILE LOOP *) END; (* PROCESS INFO *) (*****************************) (* MAIN PROGRAM BEGINS HERE *) (*****************************) BEGIN (* MORTGAGE PROGRAM *) INITIALIZE; DOCUMENT; PROCCESS_INFO; WRITELN(CHR(7)); WRITELN('TO VIEW THE TABLE OR SLIPS USE GEM TO SHOW OR'); WRITELN('PRINT THE DOCUMENT'); END. (* OF HOME MORTGAGE PROGRAM *) `A6 o"h#B#B#B ,Oc.N//Bg?<JNA BbByBN/,HNVA@-HA]"O2"N#?/0. ?N:hN;N?/A0 .2.N^,_ _PN/,HNVA-HByCzByCxByCtBBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC0 BBgAC~0 N^,_Nu/,HNVA-Hp=@ nnHyBN'XRn`HyBHzL?<-N(N'XHyBHz?<7N(N'XHyBN'XHyBHz?<%N(N'XHyB//HyCNN5XHyBHz8?<5N(N'XHyB//HyCNN5XHyBHz?<'N(N'XHyBHyCzN64N5XHyBHzt?<,N(N'XHyBHyCxN64N5X09CxCz3C|3C|CvAC]"O2"AC0 HyBHz?<+N(N'XHyBHz?<N(N'XHyBHnN5Xp=@ nnHyBN'XRn`HyBHzF?<N(XHyBHz?</N(N'XHyBHz?<N(XHyBHz?<)N(N'XHyBHz>?</N(N'Xp=@ n nHyBN'XRn`N^,_Nu BELL WILL SOUNDPLEASE ALLOW SEVERAL MINUTES***>>>>>>>>>> <<<<<<<<<<*** PROCCESSING DATA & WRITTING TO DISK***>>>>>>>>> <<<<<<<<<<*** AND THEN HIT RETURNINSERT A BLANK FORMATTED DISK INTO DRIVE A:ENTER THE NUMBER OF PAYMENT PERIODS PER YEARENTER THE DURATION OF THE LOAN IN YEARSENTER THE FULL AMOUNT OF THE MORTGAGE INCLUDING CENTSENTER THE INTREST RATE IN PERCENT (%)FOR YOU WHEN YOU SUPPLY THE FOLLOWING LOAN INFORMATION:THIS PROGRAM WILL CALCULATE MORTGAGE PAYMENTS/,HNVA 6-HHyDHz ^?<NHyDHz ,?<N(AC]"O2"//?< ?<N*PN'XHyDHz ?< N(?9Cz?<N(:Hz ?<N(N'XHyD?9CxN(@Hz z?<N(N'XHyDHz F?<N(AC]"O2"//?< ?<N*PN'XHyDN'XHyDHz ?<'N(XHyDHz ?<N(N'XHyDHz `?<$N(XHyDHz (?<"N(N'XHyCHz ?<NHyCHz ?<N(AC]"O2"//?< ?<N*PN'XHyCHz ?<N(AC]"O2"//?< ?<N*P?<%N'N'XHyCHz 2?<N(?9Cz?<N(:Hz ?<N(N'XHyCHz ?<N(?9C|?<N(:Hz ?< N(XHyCHz z?<N(N'XHyCHz :?<#N(N'XHyCN'XHyCN'Xp3Ct09C|yCtmbAC]"O2"?9CxN:hN~?"n0)?.Hn?<NR2FAA@d>~@"n0)@d`~A~B0.reAW0.rEAWÄC~CnBd~D~EBn~FBn~G"n/ N7~H"np)=@~I0.r+AW0.r-AW~JCBd@~K~L0.r-AW=B~M"n/ N7~N"n~Op)=@~P`~PBn~Q~R~R?.~SHn?<NR0@dH~T~Up=@~V0. n@=@~W"n/ N7~X"n~Yp)=@~Z?.Hn?<NR0F@"ni@dx~[0.rڰA\0.r&A_~\CBdn~]0.@d0"n$n J]&O6&0.?N?N< I0 `0~]"n$n J]&O6&0.?N?~^N; I0 `,~_~_CO$O#p"Q?< ~`~a~bNAR~c~d0.@d8~e~f~f0.@d""n~g$n J]&O6&N; I0 ~h`,~i~iC4O$O pQ?< ~j~k~lNARN^,_X> _O NError during Read of Real numberOverflow during Read of Real numberHE8 _024SBgQ@4BAAc/LE8NuHyNAxRange error during set-operationHE8 _0246@SCBgQAn68DCCc 0AgRB`/LE8NuHE8 _0@CEHS@rIVW.J?/LE8NuHE8 _0@CEHS@rIVV.J?/LE8NuHE8 _0@CEHS@2FA_VW.J?/LE8NuHE8 _0@CEHS@2FAYVW.J?/LE8NuHE8 _0@274BAAc7V`tO>/LE8NuHE8 _0@"_24BAAc1V`t>/LE8NuHE8 _02S@AC2YQ/LE8NuHE8 _02S@AC2YQ/LE8NuHE8 _02S@AC2FAYQ/LE8NuB9EP`PEPByB _0g$_jp"_// HERNLERJ@fP)J9EPf" f |` f|` f |` f|`4<G BQB) @ef *:f^&Jrt `e QG g8 fp@`*S@rG   e gRAQJ9EPg`tJ)f8a J9EPg| _0< HyZNAb|#|3|Nu )bJ) g )g )g ) f J9EPfgHBNu|/ BgHi ?<ANA>3|NAXNuNux ?Hz~/,HNVA]"O2"~ ? .2.N^,_X> _\NOverflow in Expn ?Hz~S/,HNVBBgA0 ~TA]"O2"?</<N90=@~UA]"O2"~VBBgN90@d ~WC^O$OpQNAt~X~Y0.@d&?</<A]"O2"N _\NAttempted Ln of negative number _4` _t6 Bo r aSB`2aNH?) _r ar a/L?)Nu _r aN _4` _t"x0HgJJjDxvC)zp cRЀ`|e W0R"f`6 _4` _t2xJAjDAxvC)p0 2H@0RJAfJg<-RBlCSBr aQSCaQN _4v` _46"_JBjtClBSCr aQSBk aQN _v` _60@d C)t`C)tClBSCr aQSBavQNFALSETRUE _6kfv2_t Cc"4YBv` _6kfv"_t Cc4QBvSBkr a(QSCC" A0 9c^a JgYC`NH )"oA/ N4L )NuNuputchar ?Hz~/,HNV V"h0.@~ V"h/ N4~N^,_X> _TNwrtreal ?Hz~/,HNVA]"O2"p?N:hN90=@~~0.@d.~~A]"O2"N;A0 ~0.~S@=@~0.J@jBn~~ Bn~!A]"O2"A0 ~"A]"O2"p?N?~#N90@d~$~%~&~&A]"O2"p?N?N90@d~'~(0.R@=@~)0.~*r&AoBA]"O2"p&?N?N<0.@?N?~+N0.J@W0.nR@r A^~?CBdA]"O2"p2.nRA?N??N:\N<0.@d ?<- NN0><p.? NN><0.2.><TAAo|><><?<. NN><p=@><=n0.V@=@0.nm@><><><0.rA0? NN><0.><R@=@><Sn`><p=@=n0.nn&><0.rA0?>< NNRRn`><`><><><0.U@=@0.@ =@0.nm><?< NNSn`><0.@d ?<- NN><p.? NN><?<. NN><p=@ n n"><0.rA0? NNRn`><p=@=n0.nn&><0.rA0?>< NN\Rn`><><`><><><><0.><J@k\><><0.nV@=@=n0.nn><?< NNRn`><0.@d ?<- NN><p=@0.R@=@0.nnD><><0.r An0.rA0? NN`><?<0 NN|Rn`><?<. NNh><0.R@=@><p=@=n0.nnf><><><0.R@=@><0.><r An 0.rA0?>< NN`><?<0>< NN><Rn`><`@><><><0.V@=@=n0.nn><?< NNRn`><0.@d ?<- NN~><?<0 NNp><?<. NNb><p=@><p=@=n0.nm<><><><0.nn ?<0 NN><0.><R@=@Sn`><p=@0.nR@=@0.nnH><><0.r An0.rA0? NN`><?<0>< NNRn`><><N^,_X> _ONByB(_ _/ C( g  f,t4(H / /?(?<@NA LJkffNu4(SBraQNu(gN fH ??<NAXLNu f H ??<` f H ??<` f NuHy5o` Hy5H0< LNAbREWRITE required prior to WRITE or PUTDisk or directory fullByB _$_"Wp )f)H/ N7L4NH/ N7Lp)`ByB _"WJy7f8J)f )f)H/ N7L )g)J)fJgBy7 )g J)fBiNz`zByB _$_"WptvH/ HyE^a029E^XL- -fJf^p`4  fJg*`N0eH  bBԂi\(؄iV؄iRԄiNԁRCJ)f  g )f) 0e 9c~Jg&JgDJf 6Höf4N$NHy70<` Hy70<NAbByB _$_0"Wt )gJ&JRJ)f4H/ HyE^aP29E^XL )gJ)f RBBe`ưBe`N&|E`H/ ?< NA\Hy7?< NA\LS@kQ37N Bad digit in number encounteredOverflow during READ of numberByB(_ _/ C (g ( fxJ(f t4($IH / /?(?<?NA LJk,g*fJg  f"J` g  Wf NuJgJ(f P Nu!|Nu4(SBa@J(f8Jg. fJ(f"gr W1Agp f W1A1AQNu(gVJ(fD f&H`?<NAT f?< ?<NAXp LNu fH`?<NATLNuHy9^0<` Hy9:0< LNAbReset required prior to Read or GetAttempt to read past end-of-fileHFbp`:HFbp`.HFbp`"HFbp`HFbp` HFbp _/fJ/ gLJ/kJ`L/ fJkB`</jJk2`,gbJk&` Jk`"eb// ebr`r`rAV ?/LFbNuHFbv` HFbv _ `HFbv` HFbv _0HJ[fBBg`,j Dj4<` 4<ЀkSB`Jf].B/BJg 2/.?o /@?A /LFbNuHFbv` HFbv _ [2Jkp`&4<cH@j JgR@kJ@kJgD@?/LFbNuHFbv` HFbv _ [2Jkp`$4<cd JgRkJk~JgD//LFbNuJ/ goNuNuHFb _?///` HFb _0/2// Jv/ 8://N~/DD?DBoJgJgC|k?>BGHGv8ބdRC8ބdRC>HGvކdRC8ބdRCHGv48ބBޅB:>HG8ކkE߇SDkBg|d RdRDUJg( DbRD ME \/LFbNuBBo `HFb _0/2// v/ 8://~/?DD?DBo 8JgJgG|HD8H@0zr)`рe efef<څ߇QgRCgڼd RGdSCJCkD|blo/EC \/LFbNuoHFb _p2/g/ f/W?o `ֲ@e:f$/&e&f // d*B6//J/ k`(&// S@Q`&// `R"/?/[4JfFӃddRdRR/eJd RdRd`/AG o Jk`z0H*kS/JkFft grkRBjIHA~`( dtHAI.kRBҁjBG` BBRBӁj/e2/AG o Jk\/LFbNuHFb _0 @&b(C@C/)?/LFbNuHyA`Hy@LFbNAx Hz@CPt$> nk(:C@hԥ*5 c_1ɿ1.Ź^ k:v #-xŬX&x2n)h? SYQa@%oNˏ'?9x!7I|o|@Eŭ+E75vV 9@{pvP *** Floating point overflow *** *** Floating point division by zero *** _(N _0/Ho |AH3BJyAfXNX/#F"|Aa "_a"|AaJyBg yF9BgNA/ ?< NA\Nu09BNu _3ANByBNu *** *** Copyright 1986, CCD and OSS, Inc.,"4 0    8                           NrD(X4Bh,F$bV>6,\*486l,*< * * , , 0 , " HB@6 .*4068,*(20 &*(((*((*((&&&2J @*\&<&2B(H B".44 V D   ( 0"L2 N z  f H F  V  PROGRAM mountain2; { This program is supposed to draw "Mandelbrot" shapes that resemble } { mountains. This is done by starting with a triangle figure and } { successively subdividing (randomly spaced) the sides. These points } { are then joined to form four smaller triangles within the original } { one. The process is repeated for each of these four triangles and } { onto the next step of transformation..... } { Original Pascal program written by: John O'Neill } { Translated to C for the Atari ST by: Bob Ritter (Nov. 1985) } { Translated back to Pascal(!) by Mark Rose -- 24 April, 1986 } { (sorry, but the C version didn't have many comments and I } { didn't have time to explain everything!) } CONST {$I gemconst.pas} num_steps = 7; { That's all we can generate with our array size! } two_pi = 6.2631853; TYPE {$I gemtype.pas} tree_rec = RECORD locx, locy, left, right: integer; END; VAR mtree: ARRAY[ 0..3999 ] OF tree_rec; step: integer; go_left: boolean; i, c, num_trees: integer; s, line_str: str255; scale: real; (* Was 0.22 in original version *) junk: integer; {$I gemsubs.pas} FUNCTION random: real; CONST max_random = 16777215; { 2^24 - 1 } FUNCTION irandom: long_integer; XBIOS( 17 ); BEGIN random := irandom / max_random; END; PROCEDURE str( n: integer; VAR s: str255 ); VAR digit, { Holds each digit value of 'n' as it is created } divisor, { Division by this is used to find each digit } i: integer; { Index in string at which to put next character } leading: boolean; { True, if the next digit will be the leading digit } BEGIN { str - main routine } s := ' 0'; i := 0; { Start at the beginning of the string } IF n < 0 THEN { If the number is negative, add a minus sign } BEGIN s[1] := '-'; n := -n; END; divisor := 10000; leading := true; FOR i := 2 TO 6 DO BEGIN digit := n DIV divisor; IF (digit <> 0) OR NOT( leading ) THEN BEGIN s[i] := chr(digit + ord('0')); leading := false; END; n := n MOD divisor; divisor := divisor DIV 10; END; END; { wait_button - Wait for the user to press the mouse button. Return with the X and Y position where it was pressed. } PROCEDURE wait_button( VAR x, y: integer ); VAR junk: integer; msg: Message_Buffer; BEGIN junk := Get_Event( E_Button, 1, 1, 1, 0, false, 0, 0, 0, 0, false, 0, 0, 0, 0, msg, junk, junk, junk, x, y, junk ); junk := Get_Event( E_Button, 1, 0, 1, 0, false, 0, 0, 0, 0, false, 0, 0, 0, 0, msg, junk, junk, junk, junk, junk, junk ); END; { setup - Get the scale and first three points from user. These form the first triangle in the deformation. } PROCEDURE setup; VAR junk, mx1, my1, mx2, my2, mx3, my3: integer; BEGIN { Set the system up to do GEM calls} junk := Init_Gem; Hide_Mouse; Clear_Screen; Show_Mouse; Set_Mouse( M_Point_Hand ); Draw_String( 16, 15, 'Choose desired scale:' ); Draw_String( 16, 50, '0' ); Draw_String( 215, 50, '1' ); Line( 23, 52, 215, 52 ); wait_button( mx1, my1 ); IF mx1 < 16 THEN mx1 := 16; IF mx1 > 215 THEN mx1 := 215; scale := (mx1-16) / 200; Hide_Mouse; Clear_Screen; Show_Mouse; Set_Mouse( M_Thin_Cross ); Draw_String( 16, 15, 'Click the mouse on the 3 starting co-ordinates.' ); Wait_Button( mx1, my1 ); Wait_Button( mx2, my2 ); Hide_Mouse; Line( mx1, my1, mx2, my2 ); Show_Mouse; Wait_Button( mx3, my3 ); Hide_Mouse; Line( mx2, my2, mx3, my3 ); Line( mx3, my3, mx1, my1 ); Show_Mouse; Set_Mouse( M_Arrow ); num_trees := 2; { well, really it's one more... } mtree[0].left := 1; mtree[0].right := 2; mtree[1].left := 0; mtree[1].right := 0; mtree[2].left := 0; mtree[2].right := 0; mtree[0].locx := mx1; mtree[0].locy := my1; mtree[1].locx := mx2; mtree[1].locy := my2; mtree[2].locx := mx3; mtree[2].locy := my3; END; { midpoint - Deform the midpoint of a line segment, and put the new point into the position 'mp' in the tree. } PROCEDURE midpoint( mp, x1, y1, x2, y2: integer ); VAR dx, dy, length, radius, angle: real; BEGIN dx := x2 - x1; dy := y2 - y1; length := sqrt( dx*dx + dy*dy ); radius := length * scale * random; angle := two_pi * random; mtree[mp].locx := round( (x1+x2)/2 ); { This code is deleted: + cos(angle) * radius ); -- We now only deform the midpoint in the y axis. This makes the resulting mountain look better -- MER } mtree[mp].locy := round( (y1+y2)/2 + sin(angle) * radius ); END; { transform - Compute the next iteration of the tree of mountain vertices. Each current triangle is subdivided into 4 new triangles, slightly deformed. } PROCEDURE transform( node: integer ); BEGIN IF go_left AND (mtree[mtree[node].left].left <> 0) THEN transform( mtree[node].left ); go_left := false; IF mtree[mtree[node].right].right <> 0 THEN transform( mtree[node].right ); str( c, s ); Draw_String( 32, 32, s ); c := c - 1; midpoint( num_trees+1, mtree[node].locx, mtree[node].locy, mtree[mtree[node].left].locx, mtree[mtree[node].left].locy ); midpoint( num_trees+2, mtree[mtree[node].left].locx, mtree[mtree[node].left].locy, mtree[mtree[node].right].locx, mtree[mtree[node].right].locy ); midpoint(num_trees+3, mtree[node].locx, mtree[node].locy, mtree[mtree[node].right].locx, mtree[mtree[node].right].locy ); mtree[num_trees+1].left := mtree[node].left; mtree[num_trees+1].right := num_trees + 2; mtree[num_trees+3].left := num_trees + 2; mtree[num_trees+3].right := mtree[node].right; mtree[num_trees+2].left := mtree[mtree[node].left].right; mtree[num_trees+2].right := mtree[mtree[node].right].left; mtree[node].left := num_trees + 1; mtree[node].right := num_trees + 3; num_trees := num_trees + 3; END; { display - Show the current iteration of the mountain. } PROCEDURE display( node: integer ); BEGIN IF go_left AND (mtree[mtree[node].left].left <> 0) THEN display( mtree[node].left ); go_left := false; IF mtree[mtree[node].right].right <> 0 THEN display( mtree[node].right ); Line( mtree[node].locx, mtree[node].locy, mtree[mtree[node].left].locx, mtree[mtree[node].left].locy ); Line( mtree[mtree[node].left].locx, mtree[mtree[node].left].locy, mtree[mtree[node].right].locx, mtree[mtree[node].right].locy ); Line( mtree[mtree[node].right].locx, mtree[mtree[node].right].locy, mtree[node].locx, mtree[node].locy ); END; { main routine! } BEGIN line_str := 'Step: Number of points: '; setup; go_left := true; Hide_Mouse; display( 0 ); Show_Mouse; wait_button( junk, junk ); FOR step := 2 TO num_steps DO BEGIN go_left := true; c := num_trees; transform( 0 ); go_left := true; Hide_Mouse; Clear_Screen; Show_Mouse; str( step, s ); FOR i := 1 TO length(s) DO line_str[5+i] := s[i]; str(num_trees+1, s ); FOR i := 1 TO length(s) DO line_str[30+i] := s[i]; Hide_Mouse; Draw_String( 75, 15, line_str ); display( 0 ); Show_Mouse; wait_button( junk, junk ); END; END. USING PERSONAL PASCAL WITH A SINGLE DISK DRIVE ST SYSTEM -------------------------------------------------------- If you have only one single-sided disk drive, using Personal Pascal to write programs of any practical size requires some planning and disk organization. More specifically, the Pascal disk, as shipped, contains enough free space to compile perhaps two or three of the very small demo programs included on it. In following paragraphs, we describe suggested steps to take (in order of their effectiveness) in order to be able to compile larger programs. Owners of 1040ST's will find some information of value here, though simply copying all the Personal Pascal files to a double sided diskette will probably give you all the space you need for most projects. [ 1. ] Buy a second drive. You weren't looking for expensive advice like this? Sorry, keep reading: we get cheaper as we go. (But we still think that this is the only viable long-range solution for not only Pascal but several other existing or anticipated ST products.) [ 2. ] Remove all files in the DEMO and INFO folders from your working copy of the disk. Remove the folders, also. You should now be able to write 200 to 300 line programs. [ 3. ] If you have not yet purchased and installed the TOS ROMs, do so!!! Then obtain a RamDisk program (there are a couple of free ones on CompuServe and various bulletin boards) and allocate no more than 200K bytes to the RamDisk (160K may be a better compromise). You may use the RamDisk to hold your source code, work files (see "Compile Options" menu item), and/or the library files (as described in section 3, below). This is not only a relatively easy option, it is also fairly effective: compiles and/or links will be speeded up considerably. PLEASE, PLEASE, PLEASE, though, BEFORE you run your compiled program, go back to the desktop and copy your source code from the RamDisk to a physical diskette! Thanks. SPECIAL NOTE: At 200K bytes, though, the RamDisk is not large enough to hold the compiler and its associated files (and if you make the RamDisk larger, you won't have room in normal memory to run the compiler...catch 22). However, if you own a 1040ST (or are one of those brave souls who has upgraded your 520ST to a megabyte of RAM), you can create a 600K or 700K RamDisk, which is large enough to hold all the Personal Pascal files (compiler, linker, libraries, etc.) as well as all the temporary files produced during a compile. [ 4. ] Copy the files PASLIB and PASGEM to another diskette. Then remove both of them from your working disk. Then edit and compile (do NOT link) the following program: (*$M+,E-,D-*) (* a module, but no external access, no debug *) PROGRAM JUNK(); BEGIN END. From the GEM desktop, rename the object file you just produced to "PASLIB" (no extension). Then compile the program again (without linking!) and rename the object file "PASGEM" (no extension). Back in the Personal Pascal manager, specify "additional link files" as follows: B:PASGEM,B:PASLIB (if linking for GEM) or just B:PASLIB (if linking for TOS). It's a good idea to then save these options (using the menu item "Save Options"). The effect of all this is strange and wonderful: when it comes time to link your program, the manager AUTOMATICALLY requests that the files "PASGEM" and/or "PASLIB" be linked with your file ("PASGEM" only if you chose the "link for GEM" option). But now "PASGEM" and "PASLIB" are junk files, containing only a single dummy procedure. However, since you asked for the "additional" link file(s) to be included from drive B, the linker obligingly asks the operating system for them. Here is one place where TOS really shines: when you ask for a file from drive B and drive B doesn't exist, TOS automatically prompts you to remove the "A:" diskette and insert the "B:" diskette!! And, when it is time to go back and read or write files from/to drive A, TOS prompts you again. So simply follow the TOS prompts. When it asks you for the "B:" diskette, insert the one on which you placed the copies of PASLIB and PASGEM. Then, when it asks you to insert the "A:" diskette, reinsert your working disk. Voila! You just gained about 80K bytes on your working disk. COMMENTARY: Although TOS allows you to specify "B:" for any file and will keep careful track of all swaps needed, we chose to move only the library files to the second disk in order to minimize the number of disk swaps necessary. When the linker is reading in a library file, no other files are open, so a swap is necessary only at the beginning and end of the file read. If we were to put your source file (for example) on diskette "B:," you would have to swap several times as the various "INCLUDE" files were encountered and/or as the object file was written. However, if you are desparate, you might try moving ALL source files (including GEMSUBS.PAS, GEMTYPE.PAS, etc.) to disk B:. What we are doing this way is turning the situation around: almost all files will come from diskette "B:," and the only time the system will need to swap to "A:" is when it needs to load one of the Personal Pascal ".PRG" programs (the editor, compiler, or linker). CAUTION: we have not tried this procedure as of this writing. Use at your own risk. WRITING DESK ACCESSORIES USING PERSONAL PASCAL ---------------------------------------------- In order to make a Personal Pascal program into a desk accessory, you must perform a few operations which are not described in the manual. First of all, you must make sure your program can be made into an accessory as follows: 1. The start of your program should contain an S0 compiler directive. This command tells the compiler not to adjust the size of the stack. 2. You should NOT use debug mode. Either change the option setting called "Full debug mode", or use a D- command along with the S0 command. 3. The value actually returned by the Init_Gem routine is the application identification number for your program. You must save this number in a variable, instead of just testing it. Again, look at the sample accessory for details. 4. Two additional GEM messages are sent to accessories. These messages, AC_Open and AC_Close, are not declared in the GEMCONST.PAS file. You should either declare them in your program (as the sample accessory does) or add them to the GEMCONST.PAS include file. You also must respond to these messages as shown in the sample accessory. 5. You need to declare one more EXTERNAL function in your desk accessory program: FUNCTION Menu_Register( ap_id : integer ; VAR name : Str255 ) : integer ; EXTERNAL ; This function already appears in the PASGEM library, but it does not appear in GEMSUBS.PAS (you can add it there, if you wish). Use the Menu_Register function to insert the name of your accessory in the "Desk" menu. See the sample accessory for details. Next, you need to create a file called PASACC.O by running the MAKEACC.PAS program listed below. You must enter a valid stack size; although you could use most any size, we recommend 5 Kbytes. After creating the PASACC.O file, link your program as follows: 1. You must link PASACC.O as the first link file, not the object file produced by your Pascal source program. Put the name of your Pascal object program in the "Additional Link Files" field of the link options dialog box. 2. Select the "Link..." item in the files menu. When the ITEM SELECTOR dialog appears, select the file PASACC.O-- remember, your program's .O file must already be in the "Additional Link Files" list! 3. The linker should load and link your program normally. The final output file will be named PASACC.PRG. Change this to any name, but give it the extension ".ACC" (this tells GEM to load the accessory upon booting). If you have an early version of GEM/TOS, you may need to name your file DESK3.ACC (the earliest version needed the "DESK#" primary name). 4. Copy your accessory file to a backup of your boot disk, and reboot your ST. The name of your accessory should appear under the "Desk" menu. If you select your accessory, it should run. LISTING OF MAKEACC.PAS ---------------------- PROGRAM Make_Accessory ; VAR stack_size : Integer ; answer : STRING ; PROCEDURE Write_Accstart( size : Integer ) ; VAR f : FILE OF integer ; PROCEDURE Word( w : Integer ) ; BEGIN f^ := w ; put( f ) ; END ; PROCEDURE Long( l : Long_Integer ) ; BEGIN Word( Int(Shr( l, 16 )) ) ; word( Int( l ) ) ; END ; BEGIN writeln( 'Opening PASACC.O...' ) ; rewrite( f, 'pasacc.o' ) ; writeln( 'Writing data...' ) ; (* Put out the object file header: *) Word( $601A ) ; Long( $14 ) ; Long( 0 ) ; Long( size+4 ) ; Long( 0 ) ; Long( 0 ) ; Long( 0 ) ; Word( 0 ) ; (* Now the code: *) Word( $4FF9 ) ; (* lea user_stack,sp *) Long( size ) ; Word( $41F9 ) ; (* lea stack_start,a0 *) Long( 0 ) ; Word( $2248 ) ; (* movea.l a0,a1 *) Word( $4EF9 ) ; (* jmp prg_start+12 *) Long( $20 ) ; (* Now the relocation information: *) Word( 7 ) ; Long( $50003 ) ; Word( 7 ) ; Long( $50003 ) ; Word( 7 ) ; Word( 7 ) ; Long( $50002 ) ; writeln( 'Finished!' ) ; END ; BEGIN REPEAT write( 'How many Kbytes for desk accessory stack? ' ) ; readln( stack_size ) ; write( stack_size:1, ' Kbytes-- is this correct? ' ) ; readln( answer ) ; UNTIL (length(answer) > 0) AND ((answer[1] = 'y') OR (answer[1] = 'Y')) ; IF ((answer[1] = 'y') OR (answer[1] = 'Y')) THEN Write_Accstart( stack_size*1024 ) ; END. LISTING OF ACCDEMO.PAS (SAMPLE ACCESSORY) ----------------------------------------- (* We don't want any stack (PASACC.O takes care of the stack) and we certainly shouldn't be in full debug mode! *) (*$S0,D-*) PROGRAM Sample_Accessory ; CONST (*$I gemconst.pas*) AC_Open = 40 ; (* Two new messages which only accessories will get. *) AC_Close = 41 ; TYPE (*$I gemtype.pas*) VAR window, (* The handle of our window. *) ap_id, (* Our application identification handle. *) menu_id : integer ; (* Index of our menu item in "Desk" menu. *) our_name, (* The name of our accessory. *) wind_name : Str255 ; (* The title of our window. *) (*$I gemsubs.pas*) (* You must declare this function either in your accessory program (as here) or in the GEMSUBS.PAS file: *) FUNCTION Menu_Register( id : integer ; VAR name : Str255 ) : integer ; EXTERNAL ; (* Open our window, if not already open. If our window IS open already, just make it the front window. *) PROCEDURE Do_Open ; BEGIN (* Does our window already exist? *) IF window <> No_Window THEN Bring_To_Front( window ) (* Yes, just make it front window. *) ELSE BEGIN (* No, open a new window. *) wind_name := ' Accessory Test ' ; window := New_Window( G_Name|G_Close|G_Size|G_Move, wind_name, 0, 0, 0, 0 ) ; Open_Window( window, 0, 0, 0, 0 ) END END ; (* Close our window and delete it from the system. *) PROCEDURE Do_Close ; BEGIN Close_Window( window ) ; Delete_Window( window ) ; window := No_Window END ; (* Redraw an area of our window. The area to redraw is passed in the parameters x0, y0, w0, and h0. For simplicity, we just draw a rectangle of the same size as the area to redraw and draw an X in it. This is also interesting to watch since it shows exactly what redraw messages GEM is sending. *) PROCEDURE Do_Redraw( handle, x0, y0, w0, h0 : integer ) ; VAR x, (* These four variables are used to hold the size of *) y, (* the current rectangle in the list for our window. *) w, h : integer ; BEGIN Begin_Update ; (* Tell GEM we are updating, *) Hide_Mouse ; (* and hide mouse so we don't mess up screen. *) Paint_Color( White ) ; (* We'll be clearing each rectangle w/ white. *) (* This loop should look familiar, since it is copied out of the Pascal manual, p. 5-115, except for correcting a couple of errors! *) First_Rect( handle, x, y, w, h ) ; WHILE (w <> 0) AND (h <> 0) DO BEGIN IF Rect_Intersect( x0, y0, w0, h0, x, y, w, h ) THEN BEGIN (* The only thing that's new is what we're drawing: *) Set_Clip( x, y, w, h ) ; Paint_Rect( x, y, w, h ) ; (* First clear to white... *) Frame_Rect( x, y, w, h ) ; (* Then draw rectangle outline *) Line( x, y, x+w-1, y+h-1 ) ; (* and two lines to form an X. *) Line( x+w-1, y, x, y+h-1 ) END ; Next_Rect( handle, x, y, w, h ) ; END ; Show_Mouse ; (* OK, we can redraw the mouse, too, *) End_Update (* and tell GEM we're finished! *) END ; (* This next routine performs all events we receive from GEM. Since we are an accessory, we will never reach a state where we will stop running, so the loop below (for each event we get) is infinite! *) PROCEDURE Event_Loop ; VAR event, dummy : integer ; msg : Message_Buffer ; BEGIN WHILE true DO BEGIN (* Get one event-- we're only interested in messages. *) event := Get_Event( E_Message, 0, 0, 0, 0, false, 0, 0, 0, 0, false, 0, 0, 0, 0, msg, dummy, dummy, dummy, dummy, dummy, dummy ) ; CASE msg[0] OF AC_Open: IF msg[4] = menu_id THEN (* If our menu item was selected, *) Do_Open ; (* open the window! *) AC_Close: (* If we haven't already closed our window, pretend it's closed (because GEM is going to close it for us!) Presumably, the program that was running when we were opened has finished. *) IF (msg[4] = menu_id) AND (window <> No_Window) THEN window := No_Window ; WM_Sized, (* Allow any size or position on the screen. *) WM_Moved: (* (we really should have a minimum size!) *) Set_WSize( msg[3], msg[4], msg[5], msg[6], msg[7] ) ; WM_Closed: (* User wants to close our window-- close it. *) Do_Close ; WM_Redraw: (* Need to redraw a portion of our window. *) Do_Redraw( msg[3], msg[4], msg[5], msg[6], msg[7] ) ; WM_Topped: (* Aha, user wants us to be front window! *) Bring_To_Front( msg[3] ) ; END END END ; (* Main routine-- initialize GEM, then insert our name into the "Desk" menu and go to our event loop. That routine will NEVER return! That's why we don't need an Exit_Gem call at the end of the program. *) BEGIN ap_id := Init_Gem ; (* We do need to save our application ID... *) IF ap_id >= 0 THEN (* that's a change from most programs. *) BEGIN (* Starting off with no window on the screen: *) window := No_Window ; (* Always put two spaces before the name of the accessory: *) our_name := ' Sample Accessory' ; (* Here is where we use the application ID number: *) menu_id := Menu_Register( ap_id, our_name ) ; Event_Loop ; END END. {* File: PEEKPOKE.INC *} function peeki(addr: long_integer): integer; external; procedure pokei(addr: long_integer; data: integer); external; function peekl(addr: long_integer): long_integer; external; procedure pokel(addr: long_integer; data: long_integer); external; ` y3 Nu y0 Nu y# Nu y Nu/9?<&NN\Nu###a09 /9Nu#3 ##a/9Nu###a 9 /9Nu#3 ##*a`/9NuPEEKIHPOKEInPEEKLPOKEL_PEEKIaddridata _POKEI_PEEKL_POKEL*SUPEXEC8routineretaddr* File: PEEKPOKE.S * ************************************************************************ * P E E K P O K E * ------------------- * Purpose: * A module to place peek and poke routines. * * Routines: * PEEKI(addr) - Return Integer data from addr. * POKEI(addr, idata) - Place Integer data into memory addr. * PEEKL(addr) - Return Long_Integer data from addr. * POKEL(addr, ldata) - Place Long_Integer data into memory addr. * * Notes: * These routines use SUPEXEC so they can access 'supervisor mode' memory. * * addr - is a long_integer (32 bits). * idata - is a integer (16 bits). * ldata - is a long_integer (32 bits). * * Look at the file 'PEEKPOKE.INC' for PASCAL declarations. * * Assembly language routines MUST pull all parameters from the stack * before returning to a Personal PASCAL program. * * Data returned to Personal PASCAL is stored in DO. * * David Story Feb. 22, 1986 Original Development ************************************************************************ * .text * * * Make the names global, so they can be linked. (UPPERCASE for Personal PASCAL) * .globl PEEKI .globl POKEI .globl PEEKL .globl POKEL * *** * _PEEKI * -------- * Routine to be passed to SUPEXEC shell. *** _PEEKI: movea.l addr, a0 ;a0:= addr move.w (a0), idata ;idata:= a0^ rts * *** * _POKEI * -------- * Routine to be passed to SUPEXEC shell. *** _POKEI: movea.l addr, a0 ;a0:= addr move.w idata, (a0) ;a0^:= idata rts * *** * _PEEKL * -------- * Routine to be passed to SUPEXEC shell. *** _PEEKL: movea.l addr, a0 ;a0:= addr move.l (a0), idata ;idata:= a0^ rts * *** * _POKEL * -------- * Routine to be passed to SUPEXEC shell. *** _POKEL: movea.l addr, a0 ;a0:= addr move.l idata, (a0) ;a0^:= idata rts * *** * SUPEXEC * --------- * Routine to call XBIOS SUPEXEC function. *** SUPEXEC: move.l routine, -(sp) ;push routine address on stack move.w #38, -(sp) ;push function number trap #14 ;Call XBIOS addq.l #6, sp ;correct stack rts * * * *** * PEEKI * ------- * Routine to be called from Personal PASCAL. *** PEEKI: move.l (sp)+, retaddr ;retaddr:= (sp) move.l (sp)+, addr ;addr:= (sp) move.l #_PEEKI, routine ;routine:= _PEEKI jsr SUPEXEC ;Call SUPEXEC shell move.w idata, d0 ;d0:= idata move.l retaddr, -(sp) ;(sp):= retaddr rts * *** * POKEI * ------- * Routine to be called from Personal PASCAL. *** POKEI: move.l (sp)+, retaddr ;retaddr:= (sp) move.w (sp)+, idata ;idata:= (sp) move.l (sp)+, addr ;addr:= (sp) move.l #_POKEI, routine ;routine:= _POKEI jsr SUPEXEC ;Call SUPEXEC shell move.l retaddr, -(sp) ;(sp):= retaddr rts * *** * PEEKL * ------- * Routine to be called from Personal PASCAL. *** PEEKL: move.l (sp)+, retaddr ;retaddr:= (sp) move.l (sp)+, addr ;addr:= (sp) move.l #_PEEKL, routine ;routine:= _PEEKL jsr SUPEXEC ;Call SUPEXEC shell move.l idata, d0 ;d0:= idata move.l retaddr, -(sp) ;(sp):= retaddr rts * *** * POKEL * ------- * Routine to be called from Personal PASCAL. *** POKEL: move.l (sp)+, retaddr ;retaddr:= (sp) move.w (sp)+, idata ;idata:= (sp) move.l (sp)+, addr ;addr:= (sp) move.l #_POKEL, routine ;routine:= _POKEL jsr SUPEXEC ;Call SUPEXEC shell move.l retaddr, -(sp) ;(sp):= retaddr rts * * * Define data storage requirements. * .bss .even * retaddr .ds.l 1 ;Return address to be remembered addr .ds.l 1 ;Address of memory location to access routine .ds.l 1 ;Address of routine to call idata .ds.l 1 ;Data to poke into memory somewhere * .end { FixPas - Patch bugs in PASGEM library and COMPILER.PRG; resultant version is identical with 1.02. Compile this patch program for TOS (but it doesn't really matter much). To perform the patch after compiling the program, 1. Make a copy of your master disk (or your normal Pascal disk) 2. Copy the FIXPAS.TOS program to this new disk. 3. From either TOS or the Pascal manager, run the FIXPAS program. The new disk now contains patched versions of the GEM library and the Pascal Compiler. } PROGRAM FixPas ; VAR f : PACKED FILE OF byte ; patch_pos : long_integer ; PROCEDURE patch( old_val, new_val : BYTE ) ; BEGIN get( f, patch_pos ) ; IF (f^ <> old_val) AND (f^ <> new_val) THEN BEGIN writeln( 'File doesn''t match: ', patch_pos:6:h, ' ', f^:2:h ) ; halt END ; f^ := new_val ; put( f, patch_pos ) ; patch_pos := patch_pos + 1 ; END ; PROCEDURE patch_pasgem ; BEGIN reset( f, 'pasgem' ) ; patch_pos := 11587 {$2d43} ; patch( $0e, $0c ) ; patch_pos := 11600 {$2d50} ; patch( $5c, $58 ) ; patch_pos := 21902 {$558e} ; patch( $54, $47 ) ; patch_pos := 37094 {$90e6} ; patch( $48, $38 ) ; patch( $c5, $05 ) ; patch( $d1, $e5 ) ; patch( $c5, $44 ) ; patch( $d1, $d0 ) ; patch( $c5, $c4 ) ; patch_pos := 37144 {$9118} ; patch( $67, $60 ) ; END ; PROCEDURE patch_compiler ; BEGIN reset( f, 'compiler.prg' ) ; patch_pos := 106550 {$1a036} ; patch( $46, $7c ) ; patch( $61, $46 ) ; patch( $74, $62 ) ; patch( $61, $74 ) ; patch( $6c, $61 ) ; patch( $20, $6c ) ; patch( $65, $20 ) ; patch( $72, $65 ) ; patch_pos := 106559 {$1a03f} ; patch( $6f, $72 ) ; patch( $72, $6f ) ; patch( $21, $72 ) ; patch( $5d, $21 ) ; patch( $5b, $20 ) ; patch( $20, $5d ) ; patch( $41, $5b ) ; patch( $62, $41 ) ; patch( $6f, $62 ) ; patch( $72, $6f ) ; patch( $74, $72 ) ; patch( $20, $74 ) ; patch_pos := 122165 {$1dd35} ; patch( $01, $02 ) ; END ; BEGIN patch_pasgem ; patch_compiler ; END. PROGRAM Pformat (INPUT, OUTPUT); { AUTHOR: andy j s decepida 16 Nov 1984 DESCRIPTION: Reads in a .PAS text file and, depending on the user's choice/s, generates a copy with alterations in the case of the contained text. } { Converted to O.S.S. Personal Pascal for the Atari 520ST by Jerry LaPeer of LaPeer Systems Inc. 05/20/86 - Concentrated on implementing Alert Boxes, and Dialog Boxes for input. } CONST Array_Size = 177; {$I GEMCONST.PAS} TYPE Answer_Set = SET OF CHAR; Cursor_Size = (Full, Half, Minimum, Invisible); Global_Strg = STRING[255]; Case_Types = (Upper, Lower, Asis); OptTypes = (UCase,LCase,AsIsOpt,BoreLand); {$I gemtype.pas} VAR Io_Template, Work_Template, Proc_Label, Mask, Temp, Temp_String, Ifname, Ofname : Global_Strg; Text_File, Pretty_Output : TEXT; Token : ARRAY [1..Array_Size] OF STRING[20]; Res_Case, Non_Res_Case : Case_Types; Strt, Endd, Indx, Token_Locn, Len, Cnt : INTEGER; Cd_Char, Prior, Next : CHAR; Borland_Convention, Interruptable, Comment_Active, Ok : BOOLEAN; Dialog : Dialog_Ptr ; Button, Ok_Btn, Cancel_Btn, Prompt_Item, Date_Item : INTEGER ; Can_Prog: BOOLEAN; ResOpt: OptTypes; NrsOpt: OptTypes; ExtOpt: OptTypes; Reply: Str255; {$I gemsubs} {*****************************************************************************} FUNCTION Io_Result : INTEGER; EXTERNAL; PROCEDURE Delay(I : INTEGER); BEGIN END; FUNCTION KeyPressed : BOOLEAN; BEGIN KeyPressed := KeyPress; END; {*****************************************************************************} PROCEDURE GotoXY(Col,Row : INTEGER); BEGIN WRITE(CHR($1b),'Y',CHR(Row+$1f),CHR(Col+$1f)); END; PROCEDURE CrtExit; BEGIN END; PROCEDURE ClrScr; BEGIN Clear_Screen; END; PROCEDURE ClrEol; BEGIN END; {*****************************************************************************} PROCEDURE Sound(Slen : INTEGER); BEGIN END; PROCEDURE NoSound; BEGIN END; PROCEDURE TextColor (Color : INTEGER); BEGIN END; PROCEDURE TextBackGround (Color : INTEGER); BEGIN END; PROCEDURE Set_Cursor (Size : Cursor_Size); { cursor is set according to the passed Size ... IBM-PC specific! } BEGIN END; {*****************************************************************************} PROCEDURE Init_A1; BEGIN Token [ 1] := 'ABSOLUTE'; Token [ 2] := 'ARCTAN'; Token [ 3] := 'ASSIGN'; Token [ 4] := 'AUXINPTR'; Token [ 5] := 'AUXOUTPTR'; Token [ 6] := 'BLOCKREAD'; Token [ 7] := 'BLOCKWRITE'; Token [ 8] := 'BOOLEAN'; Token [ 9] := 'BUFLEN'; Token [ 10] := 'CLREOL'; Token [ 11] := 'CLRSCR'; Token [ 12] := 'CONCAT'; Token [ 13] := 'CONINPTR'; Token [ 14] := 'CONOUTPTR'; Token [ 15] := 'CONSTPTR'; Token [ 16] := 'CRTEXIT'; Token [ 17] := 'CRTINIT'; Token [ 18] := 'DELETE'; Token [ 19] := 'DELLINE'; Token [ 20] := 'DOWNTO'; Token [ 21] := 'EXECUTE'; Token [ 22] := 'EXTERNAL'; Token [ 23] := 'FILEPOS'; Token [ 24] := 'FILESIZE'; Token [ 25] := 'FILLCHAR'; Token [ 26] := 'FORWARD'; Token [ 27] := 'FREEMEM'; Token [ 28] := 'FUNCTION'; Token [ 29] := 'GETMEM'; Token [ 30] := 'GOTOXY'; Token [ 31] := 'GRAPHBACKGROUND'; Token [ 32] := 'GRAPHCOLORMODE'; Token [ 33] := 'GRAPHMODE'; Token [ 34] := 'GRAPHWINDOW'; Token [ 35] := 'HEAPSTR'; Token [ 36] := 'HIRESCOLOR'; Token [ 37] := 'INLINE'; Token [ 38] := 'INSERT'; Token [ 39] := 'INSLINE'; Token [ 40] := 'INTEGER'; Token [ 41] := 'IORESULT'; Token [ 42] := 'KEYPRESSED'; Token [ 43] := 'LENGTH'; Token [ 44] := 'LONGFILEPOS'; Token [ 45] := 'LONGFILESIZE'; Token [ 46] := 'LONGSEEK'; Token [ 47] := 'LOWVIDEO'; Token [ 48] := 'LSTOUTPTR'; Token [ 49] := 'MAXAVAIL'; Token [ 50] := 'MAXINT'; Token [ 51] := 'MEMAVAIL'; Token [ 52] := 'NORMVIDEO'; Token [ 53] := 'NOSOUND'; Token [ 54] := 'OUTPUT'; Token [ 55] := 'PACKED'; Token [ 56] := 'PALETTE'; Token [ 57] := 'PROCEDURE'; Token [ 58] := 'PROGRAM'; Token [ 59] := 'RANDOMIZE'; Token [ 60] := 'RANDOM'; Token [ 61] := 'READLN'; Token [ 62] := 'RECORD'; Token [ 63] := 'RELEASE'; Token [ 64] := 'RENAME'; Token [ 65] := 'REPEAT'; Token [ 66] := 'REWRITE'; Token [ 67] := 'SIZEOF'; Token [ 68] := 'STRING'; Token [ 69] := 'TEXTBACKGROUND'; Token [ 70] := 'TEXTCOLOR'; Token [ 71] := 'TEXTMODE'; Token [ 72] := 'UPCASE'; Token [ 73] := 'USRINPTR'; Token [ 74] := 'USROUTPTR'; Token [ 75] := 'WHEREX'; Token [ 76] := 'WHEREY'; Token [ 77] := 'WINDOW'; Token [ 78] := 'WRITELN'; Token [ 79] := 'ARRAY'; Token [ 80] := 'BEGIN'; Token [ 81] := 'CHAIN'; Token [ 82] := 'CLOSE'; Token [ 83] := 'CONST'; Token [ 84] := 'DELAY'; Token [ 85] := 'ERASE'; Token [ 86] := 'FALSE'; Token [ 87] := 'FLUSH'; Token [ 88] := 'HIRES'; END; PROCEDURE Init_A2; BEGIN Token [ 89] := 'INPUT'; Token [ 90] := 'LABEL'; Token [ 91] := 'MSDOS'; Token [ 92] := 'PORTW'; Token [ 93] := 'RESET'; Token [ 94] := 'ROUND'; Token [ 95] := 'SOUND'; Token [ 96] := 'TRUNC'; Token [ 97] := 'UNTIL'; Token [ 98] := 'WHILE'; Token [ 99] := 'WRITE'; Token [100] := 'ADDR'; Token [101] := 'BYTE'; Token [102] := 'CASE'; Token [103] := 'CHAR'; Token [104] := 'COPY'; Token [105] := 'CSEG'; Token [106] := 'DRAW'; Token [107] := 'DSEG'; Token [108] := 'ELSE'; Token [109] := 'EOLN'; Token [110] := 'FILE'; Token [111] := 'FRAC'; Token [112] := 'GOTO'; Token [113] := 'HALT'; Token [114] := 'INTR'; Token [115] := 'MARK'; Token [116] := 'MEMW'; Token [117] := 'MOVE'; Token [118] := 'PLOT'; Token [119] := 'PORT'; Token [120] := 'PRED'; Token [121] := 'READ'; Token [122] := 'REAL'; Token [123] := 'SEEK'; Token [124] := 'SQRT'; Token [125] := 'SSEG'; Token [126] := 'SUCC'; Token [127] := 'SWAP'; Token [128] := 'TEXT'; Token [129] := 'THEN'; Token [130] := 'TRUE'; Token [131] := 'TYPE'; Token [132] := 'WITH'; Token [133] := 'AND'; Token [134] := 'AUX'; Token [135] := 'CHR'; Token [136] := 'CON'; Token [137] := 'COS'; Token [138] := 'DIV'; Token [139] := 'END'; Token [140] := 'EOF'; Token [141] := 'EXP'; Token [142] := 'FOR'; Token [143] := 'INT'; Token [144] := 'KBD'; Token [145] := 'LST'; Token [146] := 'MEM'; Token [147] := 'MOD'; Token [148] := 'NEW'; Token [149] := 'NIL'; Token [150] := 'NOT'; Token [151] := 'ODD'; Token [152] := 'OFS'; Token [153] := 'ORD'; Token [154] := 'POS'; Token [155] := 'PTR'; Token [156] := 'SEG'; Token [157] := 'SET'; Token [158] := 'SHL'; Token [159] := 'SHR'; Token [160] := 'SIN'; Token [161] := 'SQR'; Token [162] := 'STR'; Token [163] := 'TRM'; Token [164] := 'USR'; Token [165] := 'VAL'; Token [166] := 'VAR'; Token [167] := 'XOR'; Token [168] := 'DO'; Token [169] := 'HI'; Token [170] := 'IF'; Token [171] := 'IN'; Token [172] := 'LN'; Token [173] := 'LO'; Token [174] := 'OF'; Token [175] := 'OR'; Token [176] := 'PI'; Token [177] := 'TO'; END; PROCEDURE Init_A3; BEGIN END; PROCEDURE Init_Array; { initialize the reserved word array Warning: because the primitive parsing method employed here centred crucially on this array it is NOT recommended that you alter the contents and sequence of the entries. My apologies non MS-DOS users for not including the reserved words that their TurboPascal editions do support. Should you, as say as CP/M Turbo programmer, wish to alter this table keep in mind two things: ~ Do_Turbo_Extension uses the index (INDX) corresponding to the table entry of a found reserved word to assign the Borland type setting style to the output substring ... ergo, keep the new array indices in synch with the CASE selectors in Do_Turbo_Extension. ~ Since pFORMAT sequentially steps through this array to find a corresponding pattern occurrences in the text line currently being processed, it becomes important to keep the shorter reserved words that are embedded in other, longer reserved words as substrings towards the bottom of the array! } BEGIN {Init_Array} Init_A1; Init_A2; END; {Init_Array} {*****************************************************************************} FUNCTION Is_Special_Char (Ch : CHAR) : BOOLEAN; { TRUE if Ch is a special char } BEGIN Is_Special_Char := (ORD(Ch) IN [32, 39..47, 58..62, 91, 93, 123, 125]) END; {*****************************************************************************} FUNCTION Lo_Case (Ch : CHAR) : CHAR; { returns lower case of an alpha char } BEGIN IF (Ch IN ['A'..'Z']) THEN Ch := CHR (ORD(Ch) - ORD('A') + ORD('a')); Lo_Case := Ch END; {*****************************************************************************} FUNCTION UpCase(C : CHAR) : CHAR; BEGIN IF C IN ['a'..'z'] THEN UpCase := CHR(ORD(C) - (ORD('a') - ORD('A'))) ELSE UpCase := C; END; PROCEDURE Up_Strg (VAR Strg : Global_Strg); VAR Slot : INTEGER; BEGIN IF (LENGTH(Strg) > 0) THEN FOR Slot := 1 TO LENGTH(Strg) DO Strg[Slot] := UpCase(Strg[Slot]) END; {*****************************************************************************} PROCEDURE Lo_Strg (VAR Strg : Global_Strg); VAR Slot : INTEGER; BEGIN IF (LENGTH(Strg) > 0) THEN FOR Slot := 1 TO LENGTH(Strg) DO Strg[Slot] := Lo_Case(Strg[Slot]) END; {*****************************************************************************} FUNCTION Get_Char (Legal_Commands : Answer_Set) : CHAR; { waits for a CHAR input belonging in Legal_Commands } CONST Bks = 8; VAR Ch_In : CHAR; BEGIN WRITE ('[ ]'); WRITE (CHR(Bks), CHR(Bks), ' ',CHR(Bks)); REPEAT Set_Cursor (Full); READ (Ch_In); Ch_In := UpCase (Ch_In); IF NOT (Ch_In IN Legal_Commands) THEN BEGIN Sound (8900); Delay (10); NoSound; Sound (90); Delay (30); NoSound; END; UNTIL (Ch_In IN Legal_Commands); Set_Cursor (Minimum); Get_Char := Ch_In; END; {*****************************************************************************} FUNCTION User_Says_Yes : BOOLEAN; { waits for a y/Y or n/N CHAR input } VAR Reply : CHAR; BEGIN WRITE (' [y/n] ~ '); User_Says_Yes := (Get_Char(['Y','N']) = 'Y') END; {*****************************************************************************} PROCEDURE User_Quits; BEGIN Set_Cursor (Minimum); CrtExit; ClrScr; HALT; END; {*****************************************************************************} FUNCTION Is_A_Token : BOOLEAN; { returns TRUE if the pattern found is properly delimited } BEGIN {Is_A_Token} IF (Token_Locn + LENGTH(Token[Indx])) < Len THEN Next := Work_Template[Token_Locn + (LENGTH(Token[Indx]))] ELSE Next := '.'; IF Token_Locn > 1 THEN BEGIN Prior := Work_Template[Token_Locn - 1]; Is_A_Token := ((Is_Special_Char(Prior)) AND (Is_Special_Char(Next))); END ELSE IF Token_Locn = 1 THEN Is_A_Token := (Is_Special_Char (Next)); END; {Is_A_Token} {*****************************************************************************} PROCEDURE Mask_Out (Keyword : Global_Strg); { mask out a pattern match ... to enable multi-occurrences } VAR Slot : INTEGER; BEGIN {Mask_Out} DELETE (Work_Template, Token_Locn, LENGTH(Token[Indx])); Mask := Keyword; FOR Slot := 1 TO LENGTH(Keyword) DO Mask[Slot] := '\'; IF Work_Template = '' THEN Work_Template := Mask ELSE IF LENGTH(Work_Template) < Token_Locn THEN Work_Template := CONCAT(Work_Template, Mask) ELSE INSERT (Mask, Work_Template, Token_Locn); END; {Mask_Out} {*****************************************************************************} PROCEDURE Do_Turbo_Extension (VAR Extension : Global_Strg); BEGIN {Do_Turbo_Extension} CASE Indx OF 1 : Extension := 'Absolute'; 3 : Extension := 'Assign'; 4 : Extension := 'AuxInPtr'; 5 : Extension := 'AuxOutPtr'; 9 : Extension := 'BufLen'; 10 : Extension := 'ClrEol'; 11 : Extension := 'ClrScr'; 13 : Extension := 'ConInPtr'; 14 : Extension := 'ConOutPtr'; 15 : Extension := 'ConstPtr'; 16 : Extension := 'CrtExit'; 17 : Extension := 'CrtInit'; 19 : Extension := 'DelLine'; 21 : Extension := 'Execute'; 23 : Extension := 'FilePos'; 24 : Extension := 'FileSize'; 25 : Extension := 'FillChar'; 27 : Extension := 'FreeMem'; 29 : Extension := 'GetMem'; 30 : Extension := 'GotoXY'; 31 : Extension := 'GraphBackGround'; 32 : Extension := 'GraphColorMode'; 33 : Extension := 'GraphMode'; 34 : Extension := 'GraphWindow'; 35 : Extension := 'HeapStr'; 36 : Extension := 'HiResColor'; 37 : Extension := 'InLine'; 39 : Extension := 'InsLine'; 41 : Extension := 'IOResult'; 42 : Extension := 'KeyPressed'; 44 : Extension := 'LongFilePos'; 45 : Extension := 'LongFileSize'; 46 : Extension := 'LongSeek'; 47 : Extension := 'LowVideo'; 48 : Extension := 'LstOutPtr'; 49 : Extension := 'MaxAvail'; 52 : Extension := 'NormVideo'; 53 : Extension := 'NoSound'; 56 : Extension := 'Palette'; 59 : Extension := 'Randomize'; 60 : Extension := 'Random'; 64 : Extension := 'Rename'; 69 : Extension := 'TextBackGround'; 70 : Extension := 'TextColor'; 71 : Extension := 'TextMode'; 72 : Extension := 'UpCase'; 73 : Extension := 'UsrInPtr'; 74 : Extension := 'UsrOutPtr'; 75 : Extension := 'WhereX'; 76 : Extension := 'WhereY'; 77 : Extension := 'Window'; 81 : Extension := 'Chain'; 84 : Extension := 'Delay'; 85 : Extension := 'Erase'; 87 : Extension := 'Flush'; 88 : Extension := 'HiRes'; 91 : Extension := 'MSDos'; 92 : Extension := 'PortW'; 95 : Extension := 'Sound'; 100 : Extension := 'Addr'; 101 : Extension := 'Byte'; 105 : Extension := 'CSeg'; 106 : Extension := 'Draw'; 107 : Extension := 'DSeg'; 111 : Extension := 'Frac'; 114 : Extension := 'Intr'; 116 : Extension := 'MemW'; 117 : Extension := 'Move'; 118 : Extension := 'Plot'; 119 : Extension := 'Port'; 123 : Extension := 'Seek'; 124 : Extension := 'Sqrt'; 125 : Extension := 'SSeg'; 127 : Extension := 'Swap'; 134 : Extension := 'Aux'; 136 : Extension := 'Con'; 144 : Extension := 'Kbd'; 145 : Extension := 'Lst'; 146 : Extension := 'Mem'; 152 : Extension := 'Ofs'; 155 : Extension := 'Ptr'; 156 : Extension := 'Seg'; 158 : Extension := 'ShL'; 159 : Extension := 'ShR'; 163 : Extension := 'Trm'; 164 : Extension := 'Usr'; 167 : Extension := 'XOr'; 169 : Extension := 'Hi'; 173 : Extension := 'Lo'; 176 : Extension := 'Pi'; END; {CASE Indx OF} END; {Do_Turbo_Extension} {*****************************************************************************} PROCEDURE Do_Reserved_Word; BEGIN Temp := Token [Indx]; DELETE (Io_Template, Token_Locn, LENGTH(Token[Indx])); IF Res_Case = Lower THEN Lo_Strg (Temp); IF Borland_Convention THEN Do_Turbo_Extension (Temp); IF Io_Template = '' THEN Io_Template := Temp ELSE IF LENGTH(Io_Template) < Token_Locn THEN Io_Template := CONCAT(Io_Template, Temp) ELSE INSERT (Temp, Io_Template, Token_Locn); END; {*****************************************************************************} PROCEDURE Tablesearch; BEGIN Indx := 1; REPEAT Token_Locn := POS (Token[Indx], Work_Template); IF (Token_Locn <> 0) AND Is_A_Token THEN BEGIN {pattern match is reserved word} IF Res_Case <> Asis THEN Do_Reserved_Word; Mask_Out (Token[Indx]); Tablesearch {recurse!!!} END; IF Token_Locn <> 0 THEN {pattern match NOT reserved} Mask_Out (Token[Indx]); IF Token_Locn = 0 THEN {no pattern match} Indx := Indx + 1; UNTIL ( (Indx > Array_Size) AND (Token_Locn = 0) ); END; {*****************************************************************************} PROCEDURE Find_Token_Match; BEGIN {Find_Token_Match} REPEAT {exhaust all keyword occurrences in a line of text} Tablesearch; IF Interruptable THEN IF KeyPressed THEN BEGIN TextColor (24); TextBackGround (1); WRITELN; WRITE ('Abort pFORMAT of ',Ifname,'? '); IF User_Says_Yes THEN User_Quits END; UNTIL Token_Locn = 0; END; {Find_Token_Match} {*****************************************************************************} PROCEDURE Fix_Comment_Strings; { mask out comments & strings so as-is chars can be restored from Temp_String onto IO_Template } PROCEDURE Mask_String (Len_Comment : INTEGER); VAR Slot : INTEGER; BEGIN Temp_String := COPY (Work_Template, Strt, Len_Comment); FOR Slot := 1 TO LENGTH(Temp_String) DO Temp_String[Slot] := ' '; DELETE (Work_Template, Strt, Len_Comment); IF Work_Template = '' THEN Work_Template := Temp_String ELSE IF LENGTH(Work_Template) < STRt THEN Work_Template := CONCAT(Work_Template,Temp_String) ELSE INSERT (Temp_String, Work_Template, Strt); END; BEGIN {Fix_Comment_Strings} {DO Strings} REPEAT Strt := POS('''', Work_Template); IF Strt <> 0 THEN Work_Template[Strt] := ' '; Endd := POS ('''', Work_Template); IF Endd <> 0 THEN Work_Template[Endd] := ' '; IF ((Endd <> 0) AND (Strt <> 0)) THEN Mask_String (Endd - Strt + 1); UNTIL ((Endd = 0) OR (Strt = 0)); Strt := POS('{', Work_Template); IF Strt = 0 THEN {check again for alternative delimiter} Strt := POS ('(*', Work_Template); Endd := POS('}', Work_Template); IF Endd = 0 THEN {check again for alternate delimiter} Endd := POS('*)', Work_Template); IF Strt <> 0 THEN Comment_Active := TRUE; IF Endd <> 0 THEN Comment_Active := FALSE; IF Strt = 0 THEN IF Endd = 0 THEN IF Comment_Active THEN BEGIN Strt := 1; Mask_String (Len - Strt + 1) END ELSE BEGIN {no active comment} {do nothing} END ELSE BEGIN {endd <> 0} Strt := 1; Mask_String (Endd - Strt + 1) END ELSE IF Endd <> 0 THEN Mask_String (Endd - Strt + 1) ELSE Mask_String (Len - Strt + 1); END; {Fix_Comment_Strings} {*****************************************************************************} PROCEDURE Parse; VAR Slot : INTEGER; Makeup : BOOLEAN; BEGIN Work_Template := Io_Template; Len := LENGTH (Io_Template); Fix_Comment_Strings; Up_Strg (Work_Template); Temp_String := Io_Template; IF Non_Res_Case = Upper THEN Up_Strg (Io_Template) ELSE IF Non_Res_Case = Lower THEN Lo_Strg (Io_Template); Makeup := TRUE; FOR Slot := 1 TO LENGTH(Io_Template) DO IF Work_Template[Slot] = ' ' THEN Io_Template[Slot] := Temp_String[Slot]; Find_Token_Match; Makeup := TRUE; FOR Slot := 1 TO LENGTH(Io_Template) DO IF Work_Template[Slot] = ' ' THEN BEGIN Io_Template[Slot] := Temp_String[Slot]; Makeup := TRUE; END ELSE BEGIN IF ((Makeup) AND (Io_Template[Slot] <> ' ')) THEN BEGIN Io_Template[Slot] := UpCase(Io_Template[Slot]); Makeup := FALSE; END; IF Io_Template[Slot] IN ['_',' ','=',':', '(',')','[',']', '<','>',';','+', '-','/','*','^', ',','@','$','.'] THEN Makeup := TRUE; END; END; PROCEDURE Get_Options; VAR SelId: INTEGER; Alert_Prompt: Str255; UcBtn,LcBtn,AiBtn,BlBtn : INTEGER; FUNCTION GetOption(Title : Str255; DefOpt : OptTypes) : OptTypes; VAR I: INTEGER; BEGIN Dialog := New_Dialog( 8, 0, 0, 40, 9 ) ; I := (38 DIV 2) - (LENGTH(Title) DIV 2); IF I < 1 THEN I := 0; Prompt_Item := Add_Ditem( Dialog, G_String, None, I+2, 1, 35, 1, 0, 0 ) ; Set_Dtext( Dialog, Prompt_Item, Title, System_Font, Te_Left ) ; UcBtn := Add_Ditem( Dialog, G_Button, Selectable|exit_Btn, 2, 3, 9, 2, 2, $0000 ) ; Set_Dtext( Dialog, UcBtn, 'UPPERCASE', System_Font, Te_Center ) ; LcBtn := Add_Ditem( Dialog, G_Button, Selectable|exit_Btn, 13, 3, 9, 2, 2, $0000 ) ; Set_Dtext( Dialog, LcBtn, 'lowercase', System_Font, Te_Center ) ; AiBtn := Add_Ditem( Dialog, G_Button, Selectable|exit_Btn, 24, 3, 4, 2, 2, $1180 ) ; Set_Dtext( Dialog, AiBtn, 'AsIs', System_Font, Te_Center ) ; BlBtn := Add_Ditem( Dialog, G_Button, Selectable|exit_Btn, 30, 3, 8, 2, 2, $1180 ) ; Set_Dtext( Dialog, BlBtn, 'BoreLand', System_Font, Te_Center ) ; Ok_Btn := Add_Ditem( Dialog, G_Button, Selectable|Default|exit_Btn, 9, 6, 8, 2, 2, $1180 ) ; Set_Dtext( Dialog, Ok_Btn, 'OK', System_Font, Te_Center ) ; Cancel_Btn := Add_Ditem( Dialog, G_Button, Selectable|exit_Btn, 23, 6, 8, 2, 2, $1180 ) ; Set_Dtext( Dialog, Cancel_Btn, 'Cancel', System_Font, Te_Center ) ; Center_Dialog( Dialog ) ; Button := Do_Dialog( Dialog, 0) ; End_Dialog(Dialog); Delete_Dialog(Dialog); IF Button = UcBtn THEN GetOption := UCase ELSE IF Button = LcBtn THEN GetOption := LCase ELSE IF Button = AiBtn THEN GetOption := AsIsOpt ELSE IF Button = BlBtn THEN GetOption := BoreLand ELSE GetOption := DefOpt; Clear_Screen; END; BEGIN REPEAT Alert_Prompt := '[0][Defaults Reserved '; CASE ResOpt OF UCase : Alert_Prompt := ConCat(Alert_Prompt,'UPPERCASE|'); LCase : Alert_Prompt := ConCat(Alert_Prompt,'lowercase|'); AsIsOpt : Alert_Prompt := ConCat(Alert_Prompt,'As Is|'); BoreLand : Alert_Prompt := ConCat(Alert_Prompt,'BoreLand|'); END; Alert_Prompt := ConCat(Alert_Prompt,' Non-Reserved '); CASE NrsOpt OF UCase : Alert_Prompt := ConCat(Alert_Prompt,'UPPERCASE|'); LCase : Alert_Prompt := ConCat(Alert_Prompt,'lowercase|'); AsIsOpt : Alert_Prompt := ConCat(Alert_Prompt,'As Is|'); BoreLand : Alert_Prompt := ConCat(Alert_Prompt,'BoreLand|'); END; Alert_Prompt := ConCat(Alert_Prompt,' Extentions '); CASE ExtOpt OF UCase : Alert_Prompt := ConCat(Alert_Prompt,'UPPERCASE]'); LCase : Alert_Prompt := ConCat(Alert_Prompt,'lowercase]'); AsIsOpt : Alert_Prompt := ConCat(Alert_Prompt,'As Is]'); BoreLand : Alert_Prompt := ConCat(Alert_Prompt,'BoreLand]'); END; Alert_Prompt := ConCat(Alert_Prompt,'[ Change | Ok | Cancel ]'); SelId := Do_Alert(Alert_Prompt,0); Clear_Screen; IF SelId = 1 THEN BEGIN Alert_Prompt := ''; Alert_Prompt := ConCat('[0]', '[ Select One ]', '[ Res | Non Res | Ext ]'); SelId := Do_Alert(Alert_Prompt,0); Clear_Screen; CASE SelId OF 1 : ResOpt := GetOption('Reserved',ResOpt); 2 : NrsOpt := GetOption('Non-Reserved',NrsOpt); 3 : ExtOpt := GetOPtion('Extension',ExtOpt); END; SelId := 0; END; UNTIL SeLid IN [2..3]; END; FUNCTION Get_Ofname( Prompt : Str255; VAR Path : Path_Name) : BOOLEAN; VAR Template: Str255; Validation: Str255; I: INTEGER; I1: INTEGER; Dialog : Dialog_Ptr ; Button, Ok_Btn, Cancel_Btn, Prompt_Item, Fname_Item : INTEGER ; BEGIN IF LENGTH(Prompt) > LENGTH(Path) THEN I := LENGTH(Prompt) + 12 ELSE I := LENGTH(Path) + 12; IF I < 45 THEN I := 45; IF I > 75 THEN I := 75; Dialog := New_Dialog( 4, 0, 0, I+4, 8 ) ; I1 := (I DIV 2) - (LENGTH(Prompt) DIV 2); Prompt_Item := Add_Ditem( Dialog, G_String, None, I1+2, 1, I, 0, 0, 0 ) ; Set_Dtext( Dialog, Prompt_Item, Prompt, System_Font, Te_Center ) ; Fname_Item := Add_Ditem( Dialog, G_FText, None, 2, 3, I, 1, 0, $1180 ); Template := ''; FOR I1 := 1 TO I DO Template := ConCat(Template,'_'); Validation := ''; FOR I1 := 1 TO I DO Validation := ConCat(Validation,'p'); Set_Dedit( Dialog, Fname_Item, Template, Validation, Path, System_Font, Te_Left ) ; I1 := (I DIV 2) - 11; Ok_Btn := Add_Ditem( Dialog, G_Button, Selectable|exit_Btn|default, I1+2, 5, 8, 2, 2, $1180 ) ; Set_Dtext( Dialog, Ok_Btn, 'OK', System_Font, Te_Center ) ; Cancel_Btn := Add_Ditem( Dialog, G_Button, Selectable|exit_Btn, I1+16, 5, 8, 2, 2, $1180 ) ; Set_Dtext( Dialog, Cancel_Btn, 'Cancel', System_Font, Te_Center ) ; Center_Dialog( Dialog ) ; Button := Do_Dialog( Dialog, Date_Item ) ; Get_Dedit( Dialog, Date_Item, Template); End_Dialog(Dialog); Delete_Dialog(Dialog); Path := Template; IF Button = Cancel_Btn THEN Get_Ofname := TRUE ELSE Get_Ofname := FALSE; Clear_Screen; END; PROCEDURE Get_Ifname; VAR Path: Path_Name; BEGIN Path := 'd:*.*'; IF Get_In_File(Path, Ifname) THEN BEGIN Clear_Screen; Ofname := Ifname; Can_Prog := Get_Ofname('Pascal Formated File Name', Ofname); END ELSE BEGIN Clear_Screen; Can_Prog := TRUE; END; END; {*****************************************************************************} BEGIN {--------------------------------------------------------------- pFormat} IF Init_Gem >= 0 THEN BEGIN Clear_Screen; ResOpt := UCase; NrsOpt := LCase; ExtOpt := BoreLand; Can_Prog := FALSE; Init_Array; Reply := ConCat('[0]', '[ Abort with a Keypress? ]', '[ Yes | No | Cancel]'); CASE Do_Alert(Reply,0) OF 1 : Interruptable := TRUE; 2 : Interruptable := FALSE; 3 : Can_Prog := TRUE; END; Clear_Screen; WHILE NOT Can_Prog DO BEGIN Clear_Screen; GotoXY (1,1); Get_Ifname; IF NOT Can_Prog THEN BEGIN Get_Options; IF NOT Can_Prog THEN BEGIN CASE ResOpt OF UCase : Res_Case := Upper; LCase : Res_Case := Lower; AsIsOpt : Res_Case := AsIs; END; CASE NrsOpt OF UCase : Non_Res_Case := Upper; LCase : Non_Res_Case := Lower; AsIsOpt : Non_Res_Case := AsIs; END; CASE ExtOpt OF UCase : Borland_Convention := FALSE; LCase : Borland_Convention := FALSE; AsIsOpt : Borland_Convention := FALSE; BoreLand: Borland_Convention := TRUE; END; Clear_Screen; Hide_Mouse; Comment_Active := FALSE; RESET(Text_File,Ifname); REWRITE(Pretty_Output,Ofname); WHILE (NOT (EOF(Text_File))) AND (NOT Can_Prog) DO BEGIN READLN (Text_File, Io_Template); Parse; WRITELN (Io_Template); WRITELN (Pretty_Output, Io_Template); END; CLOSE (Text_File); CLOSE (Pretty_Output); Show_Mouse; END; END; IF NOT Can_Prog THEN CASE Do_Alert('[0][Format another program?][ Yes | No ]',0) OF 1 : Can_Prog := FALSE; 2 : Can_Prog := TRUE; END; Clear_Screen; END; Exit_Gem ; END ; END. {---------------------------------------------------------------pFormat} ; 35 : Extension := 'HeapStr'; 36 : Extension := 'HiRes Port Configuration Page 1 Configuring the I/O Ports If you are writing a program which performs I/O to one of the devices that connect to the back of the ST (i.e., a printer or a modem), you will probably want to set the configuration at some time or other. If you are writing a GEM application and you are content to use the desk accessories to allow the user to configure the ports, you can skip this section. However, the desk accessories don't always set up the configuration properly, so be careful! In any case, if you want to set the configuration of the RS232 port or the parallel port, you need to know a few calls: Set the printer configuration. We'll investigate the printer configuration first, since there are fewer parameters to explain. The following XBIOS call allows you to configure the printer: FUNCTION setprt( config : integer ) : integer ; XBIOS( 33 ) ; In order to set or get the current printer configuration, you should use this call. If config is -1, the current configuration is passed back as the return value. Otherwise, config specifies the desired configuration of the printer. The various bits within config specify the configuration as follows: bit# when 0 when 1 ---- ---------------- ----------------- 0 dot matrix daisy wheel 1 color printer monochrome 2 Atari printer Epson compatible 3 draft mode final mode 4 parallel port RS232 port 5 continuous paper single sheet 6 reserved 7 reserved 8 reserved 9 reserved 10 reserved 11 reserved 12 reserved 13 reserved 14 reserved 15 MUST BE ZERO! Configure the RS232 port. OK, on to the RS232 configuration. The following XBIOS call sets the various parameters controlling the RS232 port: PROCDURE rsconf( speed, flowctl, ucr, rsr, tsr, scr : integer ) ; XBIOS( 15 ) ; If any of the parameters is -1, the corresponding RS232 parameter is left unchanged from its previous value. You will mostly be dealing with setting the baud rate, which is governed by the speed parameter: Port Configuration Page 2 speed rate ----- ----- 0 19200 1 9600 2 4800 3 3600 4 2400 5 2000 6 1800 7 1200 8 600 9 300 10 200 11 150 12 134 13 110 14 75 15 50- The last value, 15, may not generate an accurate (as if you'll ever need it!). You may also need to change the flow-control option of the RS232 port. It is specified in the flow parameter as follows: flow flow-control ---- ------------ 0 No flow control 1 XON/XOFF (control-S/control-Q) 2 RTS/CTS 3 XON/XOFF and RTS/CTS The value 3 doesn't represent a very useful condition, but it should work. The other four parameters set registers within the 68901 chip (for a more complete, but still sketchy, discussion, see the book ST Internals). These registers perform the following functions: register function -------- -------- ucr USART control register rsr Receiver status register tsr Transmitter status register scr Synchronous character register If you are transmitting in asynchronous mode (i.e, almost always), you will probably only use the ucr parameter, which has the following meanings: ucr bits function -------- -------- 0 unused 1 parity type: 0=odd 1=even 2 parity enable: 0=no parity 1=parity 4,3 0,0 -> synchronous mode (all others asynch) 0,1 -> 1 start bit, 1 stop bit 1,1 -> 1 start bit, 2 stop bits 6,5 number of data bits 0,0 -> 8 bits 0,1 -> 7 1,0 -> 6 Port Configuration Page 3 1,1 -> 5 7 transmit and receive frequency 0 -> divide by 1 (synchronous only) 1 -> divide by 16 If you want to use the rsr, tsr, or scr registers, please refer elsewhere for more documentation on the 68901 chip (ST Internals, for example). (*$S0,D-*) PROGRAM Screen_Dump_Acc; { THIS VERSION FOR NEC PC-8023A-C } { by Ron Rautenberg 15 San Juan Dr Salinas, Ca 93901 13 Mar 1986 } { Recognizes screen resolution but only three colors - black, background(white), and other. Useful for desktop dumps but certainly not for picture files } { NOTE: one pixel is mapped to 2 printer dots - uses 640 dots per line black = x white = o other = x or o (alternating) x o o x (only if x is odd) } CONST {$I gemconst} AC_OPEN = 40; { Gem message when accessory is opened } LOW = 0; MED = 1; { screen resolution values } HI = 2; { the global parameter array types for GEM } TYPE Ctrl_Parms = ARRAY [ 0..11 ] OF integer ; Int_In_Parms = ARRAY [ 0..15 ] OF integer ; Int_Out_Parms = ARRAY [ 0..45 ] OF integer ; Pts_In_Parms = ARRAY [ 0..11 ] OF integer ; Pts_Out_Parms = ARRAY [ 0..11 ] OF integer ; {$I gemtype} VAR { global parameter arrays } control : Ctrl_Parms ; int_in : Int_In_Parms ; int_out : Int_Out_Parms ; pts_in : Pts_In_Parms ; pts_out : Pts_Out_Parms ; prt : text; { the printer } msg : Message_Buffer; { message from GEM } acc_name : str255; { our accessory's name } ap_id,menu_id, { handles } event,dummy, { temps } i,j, { loop controls } x,y, { pixel coordinates } pix_color, { pixel color } pix_per, { vertical pixels per pass } shifter, { shift value for masks } col_black, { color index for black, 3 in med rez, 15 low } rez, { screen resolution } scr_width,scr_height, { screen size } black_mask,green_mask, { masks for creating output bytes to printer } bite1 : integer; { printer output byte } {$I gemsubs} FUNCTION Get_Rez : integer ; { xbios call to get screen resolution } XBIOS( 4 ) ; { to install a desk acc. in menu bar } FUNCTION Menu_Register ( id : integer ; var name : Str255 ) : integer; EXTERNAL ; { Generic VDI call } PROCEDURE VDI_Call( cmd, sub_cmd : integer ; nints, npts : integer ; VAR ctrl : Ctrl_Parms ; VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ; VAR pts_in : Pts_In_Parms ; VAR pts_out : Pts_Out_Parms ; translate : boolean ) ; EXTERNAL ; BEGIN ap_id := Init_Gem; if ap_id >= 0 then begin acc_name := ' Print Screen'; { add us to menu bar } menu_id := Menu_Register(ap_id,acc_name); while true do begin { loop forever getting messages } event := Get_Event(E_Message,0,0,0,0,false,0,0,0,0, false,0,0,0,0,msg,dummy,dummy,dummy,dummy, dummy,dummy ) ; if msg[0] = AC_OPEN then if msg[4] = menu_id then begin { if its us } Hide_Mouse ; rez := get_rez; case rez of LOW : begin col_black := 15; scr_width := 320; scr_height := 200; end; MED : begin col_black := 3; scr_width := 640; scr_height := 200; end; HI : begin col_black := 1; scr_width := 640; scr_height := 400; end; end; pix_per := scr_height div 50; shifter := 8 div pix_per; Rewrite(prt,'lst:'); write(prt,chr(27),'T16'); { 16/144s line spacing } { divide screen into rows of 4 or 8 pixels each } for i := 0 to (scr_height div pix_per) - 1 do begin { Dot graphics, 640 cols per line } write(prt,chr(27),'S0640'); { width of screen is 320 or 640 depending on resolution } for x := 0 to scr_width - 1 do begin { initialize } { high bits are bottom pixels } if rez = HI then black_mask := 1 else black_mask := 3; case (x mod 4) of 0,2: green_mask := 0; 1 : green_mask := 1; 3 : green_mask := 2; end; bite1 := 0; { pass x coord to gem } pts_in[0] := x; { look at 4 or 8 vertical pixels at a time } for j := 0 to (pix_per - 1) do begin { y coordinate for GEM } pts_in[1] := i * pix_per + j; { get pixel color } VDI_Call(105,0,0,2,control, int_in,int_out,pts_in,pts_out,false); pix_color := int_out[0]; { mask output bytes } if pix_color = col_black then begin bite1 := bite1 | black_mask; end else if pix_color <> 0 then begin bite1 := bite1 | green_mask; end; black_mask := ShL(black_mask,shifter); green_mask := ShL(green_mask,shifter); end; { send to printer } write(prt,chr(bite1)); { twice for low res } if rez = LOW then write(prt,chr(bite1)); end; writeln(prt); end; Show_Mouse; { ALL DONE } end; end; end ; END. `!O6A""HN o"h#6#6#6BbBy6NTNV?<NNN^NuA60B1|A701|A901|Ap#6N3;09;J@kRCnE9p Q?9;Hy9NX3;p@d?<BgBgBgp/BgBgBgBgBgBgBgBgBgBgHy9Hy:Hy:Hy:Hy:Hy:Hy:N3:099r(Af099ΰy;fNN3:09:J@fp3:` p3:Hy9Hz?<NHy9p?Np?<@NpXHy9p?Np?<3Npp?NpXBy: y1:nHy9p?Np?<zNp0<?Npp?NpXBy:09:R@@S@3;09:y;n3:09:rHH@R@@3:By:By:3:8By: y:n09:@y:38?<iBgBg?<Hy8RHy8jHy8Hy8Hy8BgNZ38:09:y:f*09:y:3:09:y:3:` 09:J@g09:y:3:09:H3:09:H3:Ry:`*Hy909:?Np09:?Np09:?NpX09:J@f4Hy909:?Np09:?Np09:?NpXRy:`dHy9NXRy:`N`Hy9N0Hy7N0BgNAlst: Print ScreenNu/,HNVtN A8-H=n0. rA=@-nx?<HnHnHnxHntNN^,_ _PN/,HNVtN A2-H=n p=@-nx?< HnHnHnxHntNN^,_ _\N/,HNVtN A0-H=n Bn-nx?< HnHnHnxHntNN^,_ _\N/,HNVN A*-H/.?. A O"Op?"QBgBgNN^,_ _ON/,HNVnN AL-H"n $n p*R@r=n"n / N-@r?<#HnHnzHnrHnnN0.N^,_ _\NNu/,HNVtN AV-H=n=n=n=n=n=n=n=n=n ?<3HnHnHnxHntNN^,_ _ON/,HNVnN A@-H0. J@jBn =n -nr?<2HnHnzHnrHnnN=nz0.N^,_ _\N/,HNVN Ap-H/.BgHnHnHnHnN XBgBgBgBgBg?.?.?.?.N/.Bg?<?.?.?.?.N F/.?. N(=@0.N^,_ _\N/,HNVN AB-H/. BgHnHnHnHnN X?<BgBgBgBg?.?.?.?.NRN^,_ _XN/,HNVtN A&-H-n x?<6HnHnHnxHntNN^,_ _XN/,HNVN AR-HBn"n0.r1JAg*"n 0.R@$n2.t20.R@=@`"n 0.@N^,_ _PN/,HNVN Az-H"n Jfp. R@?"n / Np=@p. =@0.nn&"n $Q0.S@2.tA 0Rn`"n $Qp. rN^,_ _ON/,HNVN Av-H"n0.-I"n0)rAW"n0)r AWÄC"n0)rAWÄCBd("n / AO"Op?"QN`"n0)rAW"n0)rAWÄC"n0)rAWÄC"n0)rAWÄCBd"n$i -J"n0)rAW"n0)rAWÄCp."ni\CBd"n0)S@@"n Jf"np.R@3@"n/ AO"Op?"QN"n0)rAW"n0)rAWÄCBd"n3n "n3n N^,_ _O N/,HNVN AT-H"n0.-I"n0)rAW"n0)rAWÄCBd"n$i /"n / N`N^,_ _O NNu/,HNVxN =n=n -n|?<(HnHnHn|HnxNN^,_ _PN/,HNVxN =n -n|?<rHnHnHn|HnxNN^,_ _\N/,HNVxN -n|=n=n=n=n=n=n ?<*HnHnHn|HnxNN^,_ _ON/,HNVN "n0. =i 0.N^,_ _\N/,HNVxN -n|=nBn=n=n=n=n=n0. rA=@?</HnHnHn|HnxNN^,_ _ON/,HNVN /.?.HnHnHnHnN X/.?.?.?.?.?.?.?. NDN^,_ _O N/,HNVN "n0. =i0.N^,_ _\N/,HNVN "n0.3n N^,_ _PN/,HNVrN -nv=n=n=n=n ?<+HnHn~HnvHnrN=n~0.N^,_ _O NNu/,HNVtN /.?."n/ "n/ N"n0.-It"n$nt2"n $nt2"nt0) rAJ@g:"n$n0W@2"n$n0W@2"n$n0\@2"n $n 0\@2N^,_ _ONNu/,HNVxN =n-n|?<,HnHnHn|HnxN"n2"n 2N^,_ _ONNu/,HNVN =n-n ?<NHnHnHnHnNN^,_ _\N/,HNVN ?</. NN^,_ _XN/,HNVN 0. ?BNN^,_ _TN/,HNVN ?<BNdN^,_Nu/,HNVN ?<BNFN^,_Nu/,HNVN p?BN(Bn?<zBg?<BgHnHnHnHnHnBgNZN^,_Nu/,HNVN p=@?<kHnHnHnHnNN^,_Nu/,HNVN p=@?<kHnHnHnHnNN^,_NuNu/,HNVN A-H=nF=n@=nD=nB0.:rA=@=n8=n6=n4=n20.0rA=@=n. =n, =n*=n(=n>=n<-n$?<HnHnHnHnN=n"n2"n2"n2"n 2"n 2"n20.N^,_ _O g8 fp@`*S@rG   e gRAQJ9;vg`tJ)f8a J9;vg| _0< HyN0|#|3|Nu )bJ) g )g )g ) f J9;vfgHBNu|/ BgHi ?<ANA>3|NAXNu _4` _t6 Bo r aSB`2aNH? _r ar a/L?Nu _r aN _4` _t"x0HgJJjDxvCzp cRЀ`|e W0R"f`6 _4` _t2xJAjDAxvCp0 2H@0RJAfJg<-RBlCSBr aQSCaQN _4v` _46"_JBjtClBSCr aQSBk aQN _v` _60@d Ct`CtClBSCr aQSBavQNFALSETRUE _6kfv2_t Cc"4YBv` _6kfv"_t Cc4QBvSBkr a(QSCC" A0 9c^a JgYC`NH x"oA/ NL xNuBy"(_ _/ C( g  f,t4(H / /?(?<@NA LJkffNu4(SBraQNu(gN fH ??<NAXLNu f H ??<` f H ??<` f NuHy` Hy0< LN0REWRITE required prior to WRITE or PUTDisk or directory fullBy"(_ _/ C (g ( fxJ(f t4($IH / /?(?<?NA LJk,g*fJg  f"J` g  Wf NuJgJ(f P Nu!|Nu4(SBa@J(f8Jg. fJ(f"gr W1Agp f W1A1AQNu(gVJ(fD f&H`?<NAT f?< ?<NAXp LNu fH`?<NATLNuHy<0<` Hy0< LN0Reset required prior to Read or GetAttempt to read past end-of-file 6Nu# , _ g6e6d 9 ,NHy D`Hy PNFt`t _"_0gR@| e.G ($S" ghjebb"*f&"`v&A%S"`l&J`ذ|gb*|f8"9 g0$A# `""9 g$A# `"9 $g $A# $"`"E6&R"$b Hy 0NFJgr"QHd2S@k"QN _"_0" g6e6d gR@ @mz @ e@E ("fB3@B$`\&A2+@ef "'I`F"3@B$`8$K`ư|f" $# $` |f" # ` " # NHeap overruns stackPointer NILPointer not in heap _ hNVf 0(gr"OD@Hd2S@k "Q` _"y6e Hy NFN#;#; .f -| `-|  nNн;f y;NStack overruns heap09"Nu _3"NBy"Nu[3][][ Abort ]Copyright 1986, CCD and OSS, Inc.  0             &:42,0X<"$>,$8(l*lr,&D0T>0,8&&,&$$6  LD"2 T &( 0&  >         HB@6 2J X D2 T  <   , Fz  (*$S0,D-*) PROGRAM Screen_Dump_Acc; { THIS VERSION FOR GEMINI 10X } { by Ron Rautenberg 15 San Juan Dr Salinas, Ca 93901 13 Mar 1986 } { Recognizes screen resolution but only three colors - black, background(white), and other. Useful for desktop dumps but certainly not for picture files } { NOTE: one screen pixel is mapped to 6 printer dots - uses 1920 dots per line black = xxx white = ooo other = oxo or ooo (alternating) xxx ooo ooo oxo } CONST {$I gemconst} AC_OPEN = 40; { Gem message when accessory is opened } { the global parameter array types for GEM } TYPE Ctrl_Parms = ARRAY [ 0..11 ] OF integer ; Int_In_Parms = ARRAY [ 0..15 ] OF integer ; Int_Out_Parms = ARRAY [ 0..45 ] OF integer ; Pts_In_Parms = ARRAY [ 0..11 ] OF integer ; Pts_Out_Parms = ARRAY [ 0..11 ] OF integer ; {$I gemtype} VAR { global parameter arrays } control : Ctrl_Parms ; int_in : Int_In_Parms ; int_out : Int_Out_Parms ; pts_in : Pts_In_Parms ; pts_out : Pts_Out_Parms ; prt : text; { the printer } msg : Message_Buffer; { message from GEM } acc_name : str255; { our accessory's name } ap_id,menu_id, { handles } event,dummy, { temps } i,j, { loop controls } x,y, { pixel coordinates } pix_color, { pixel color } col_black, { color index for black, 3 in med rez, 15 low } rez, { screen resolution } black_mask,green_mask, { masks for creating output bytes to printer } bite1,bite2 : integer; { printer output bytes } {$I gemsubs} FUNCTION Get_Rez : integer ; { xbios call to get screen resolution } XBIOS( 4 ) ; { to install a desk acc. in menu bar } FUNCTION Menu_Register ( id : integer ; var name : Str255 ) : integer; EXTERNAL ; { Generic VDI call } PROCEDURE VDI_Call( cmd, sub_cmd : integer ; nints, npts : integer ; VAR ctrl : Ctrl_Parms ; VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ; VAR pts_in : Pts_In_Parms ; VAR pts_out : Pts_Out_Parms ; translate : boolean ) ; EXTERNAL ; BEGIN ap_id := Init_Gem; if ap_id >= 0 then begin acc_name := ' Print Screen'; { add us to menu bar } menu_id := Menu_Register(ap_id,acc_name); while true do begin { loop forever getting messages } event := Get_Event(E_Message,0,0,0,0,false,0,0,0,0, false,0,0,0,0,msg,dummy,dummy,dummy,dummy, dummy,dummy ) ; if msg[0] = AC_OPEN then if msg[4] = menu_id then begin { if its us } Hide_Mouse ; rez := get_rez; if rez = 0 then col_black := 15 { color index value for black } else col_black := 3; { is different for each res. } Rewrite(prt,'lst:'); write(prt,chr(27),'@'); { Reset Printer } write(prt,chr(27),'3',chr(16)); { set line spacing 16/144s } { divide screen into 50 rows of 4 pixels each } for i := 0 to 49 do begin { Dot graphics, 1920 cols per line } write(prt,chr(27),'z',chr(128),chr(7)); { width of screen is 320 or 640 depending on resolution } for x := 0 to ((rez + 1) * 320) - 1 do begin { initialize } { high bits are top pixels } black_mask := 192; green_mask := (x mod 2 + 1) * 64; bite1 := 0; bite2 := 0; { pass x coord to gem } pts_in[0] := x; { look at 4 vertical pixels at a time } for j := 0 to 3 do begin { y coordinate for GEM } pts_in[1] := i * 4 + j; { get pixel color } VDI_Call(105,0,0,2,control, int_in,int_out,pts_in,pts_out,false); pix_color := int_out[0]; { mask output bytes } if pix_color = col_black then begin bite1 := bite1 | black_mask; bite2 := bite2 | black_mask; end else if pix_color <> 0 then begin bite2 := bite2 | green_mask; end; black_mask := ShR(black_mask,2); green_mask := ShR(green_mask,2); end; { send to printer } write(prt,chr(bite1),chr(bite2),chr(bite1)); { twice for low res } if rez = 0 then write(prt,chr(bite1),chr(bite2),chr(bite1)); end; writeln(prt); end; Show_Mouse; { ALL DONE } end; end; end ; END. ` O2zAz"HN o"h#2~#2#2BbBy2N=n<-n$?<HnHnHnHnN=n"n2"n2"n2"n 2"n 2"n20.N^,_ _O#5:#56#52#45*#5 5.0/34| H |"|4H2H2H2094 @pf2<`2<34"<5*0<NBNu _<#5R#5J#5N#5F"_#5B:3E3_3_ 2/3y5V Jg( y5J8DSEk0 y5^00 y5\0Q?"<5B0<sNBJ_`.:94H y5RSEk0 y5^00 y5^0QNu _35VN095VNu _35XN095XNu _35^35\N _"_$_25^45\N _35b35`N _"_$_25b45`N _35ZN095ZNu _ RN _"_/) g g f0)k @e??<>3|NAXNu 2~Nu# _ g2e2~d 9NHy`HyN0 @f0"|5d5dp` "_J@jp6B@bE5SBkQ/L5fNuString overflow _ hNVf 0(gr"OD@Hd2S@k "Q` _"y2~e HyN,$8(l*lr,&D0T>0,8&&,&$$6   $LD"2 T &( 0&  >        R  <   , FR ( *@ B @ B   FIGURE 5.5 (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* *) (* STRAIGHT SELECTION SORT -- FIND THE SMALLEST ITEM AND *) (* EXCHANGE IT WITH THE FIRST ITEM OF THE *) (* ARRAY. FIND THE NEXT SMALLEST ITEM AND *) (* EXCHANGE IT WITH THE SECOND ITEM IN THE *) (* ARRAY AND SO ON. *) (* *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE SORT (VAR DATA: DATA_ARRAY; COUNT: INTEGER); VAR I, J, S: INTEGER; (* LOOP INDICES *) ITEM: INTEGER; (* THE ITEM CURRENTLY SELECTED *) BEGIN (* STRAIGHT SELECTION SORT *) FOR I := 1 TO COUNT - 1 DO BEGIN S := I; (* INITIALIZE SWITCH POSITION *) ITEM := DATA[I]; FOR J := I + 1 TO COUNT DO IF DATA[J] < ITEM THEN (* SMALLER ITEM FOUND? *) BEGIN S := J; (* REMEMBER SWITCH POSITION *) ITEM := DATA[J] (* GET NEW ITEM *) END; DATA[S] := DATA[I]; (* MAKE ROOM FOR ITEM *) DATA[I] := ITEM; (* MOVE THE ITEM DOWN *) WRITELN (SORT_TABLE,'PASS #',I:1,' ITEM = ',DATA[I]:1); PRINT_ARRAY(DATA,COUNT) END (* I LOOP *) END; (* STRAIGHT SELECTION SORT )* PROGRAM SORT_DRIVER(INPUT,OUTPUT,SORT_DAT,SORT_TABLE); (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* SORT ALGORITHM DEMONSTRATION PROGRAM *) (* PROGRAMMER: CHRIS ROBERTSON *) (* ST APPLICATIIONS DEMO *) (* *) (* DESCRIPTION: THIS PROGRAM IS DESIGNED TO BE A DRIVVER *) (* PROGRAM FOR DEMONSTRATION VARIOUS SORTING ALGORITHMS. *) (* IT READS A TEXT FILE OF INTEGERS INTO AN ARRAY AND THEN *) (* PASSES THE ARRAY TO A USER-SUPPLIED SORT ROUTINE. *) (* THE PROCEDURE PRINTARY MAY BE USED BY THE SORT ROUTINE. *) (* TO PRINT THE CURRENT CONTENTS OF THE ARRAY AT VARIOUS *) (* POINTS IN THE SORTING PROCESS, SO TO FURTHER YOUR UNDER- *) (* STANDING OF SORTING. *) (* YOU CAN PRINT THE SORT TABLE THROUGH GEM. VERSION 1.0 *) (**************************************************************) CONST MAX_ARRAY = 100; DISKA1 = 'A:SORT_DAT'; DISKA2 = 'A:SORT_TABLE'; TYPE DATA_ARRAY = ARRAY[0..MAX_ARRAY] OF INTEGER; VAR DATA: DATA_ARRAY; (* DATA ARRAY PASSED TO USER *) I, (* ROUTINE FOR SORTING *) COUNT: INTEGER; (* NUMBER OF INTEGERS IN DATA*) SORT_DAT, SORT_TABLE:TEXT; (* TEXTFILES, ONE WITH DATA, *) (* THE OTHER WITH OUTPUT *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* READ_ARRAY -- READ THE CONTENTS OF THE DATA FILE INTO *) (* THE DATA ARRAYPREPARATORY TO SORTING. *) (* NOTE: IT IS ASSUMED THAT THE DATA IS AN *) (* INDEFINITE NUMBER OF INTEGERS (NOP MORE THAN *) (* MAXARY) STORED ONE PER LINE ON THE DATA FILE *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE READ_ARRAY(VAR DATA:DATA_ARRAY; VAR COUNT:INTEGER); BEGIN (* READ_ARRAY *) RESET(SORT_DAT,DISKA1); COUNT := 0; WHILE NOT EOF(SORT_DAT) AND (COUNT <= MAX_ARRAY) DO BEGIN COUNT := COUNT + 1; READLN(SORT_DAT,DATA[COUNT]) END END; (* READ *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* *) (* PRINT_ARRAY--PRINTS THE CONTENTS OF THE ARRAY SO THAT *) (* THE SORTING PROCESS MAY BE FOLLOWED *) (* *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE PRINT_ARRAY(VAR DATA:DATA_ARRAY; COUNT:INTEGER); CONST PERLINE = 8; (* NUMBER OF DATA VALUES PRINTED *) PLACES = 8; (* ON EACH LINE *) VAR I: INTEGER; BEGIN FOR I := 1 TO COUNT DO IF (I MOD PERLINE = 0) THEN WRITELN(SORT_TABLE,DATA[I]:PLACES) ELSE WRITE(SORT_TABLE,DATA[I]:PLACES); WRITELN END; (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* *) (* STRAIGHT SELECTION SORT -- FIND THE SMALLEST ITEM AND *) (* EXCHANGE IT WITH THE FIRST ITEM OF THE *) (* ARRAY. FIND THE NEXT SMALLEST ITEM AND *) (* EXCHANGE IT WITH THE SECOND ITEM IN THE *) (* ARRAY AND SO ON. *) (* *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE SORT (VAR DATA: DATA_ARRAY; COUNT: INTEGER); VAR I, J, S: INTEGER; (* LOOP INDICES *) ITEM: INTEGER; (* THE ITEM CURRENTLY SELECTED *) BEGIN (* STRAIGHT SELECTION SORT *) FOR I := 1 TO COUNT - 1 DO BEGIN S := I; (* INITIALIZE SWITCH POSITION *) ITEM := DATA[I]; FOR J := I + 1 TO COUNT DO IF DATA[J] < ITEM THEN (* SMALLER ITEM FOUND? *) BEGIN S := J; (* REMEMBER SWITCH POSITION *) ITEM := DATA[J] (* GET NEW ITEM *) END; DATA[S] := DATA[I]; (* MAKE ROOM FOR ITEM *) DATA[I] := ITEM; (* MOVE THE ITEM DOWN *) WRITELN (SORT_TABLE,'PASS #',I:1,' ITEM = ',DATA[I]:1); PRINT_ARRAY(DATA,COUNT) END (* I LOOP *) END; (* STRAIGHT SELECTION SORT )* (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* MAIN PROGRAM--THE USER'S SORT ROUTINE SHOULD BE DECLARED*) (* AS: SORT(VAR DATA: DATA_ARRAY; COUNT:INTEGER); WHERE *) (* DESIRED IT MAY CALL PRINT_ARRAY(DATA,COUNT); *) (* TO PRINT OUT THE CURRENT STATE OF THE ARRAY BEING SORTED*) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) BEGIN (* MAIN *) REWRITE(SORT_TABLE,DISKA2); WRITELN(SORT_TABLE,'SELECTION SORT'); WRITELN(SORT_TABLE); READ_ARRAY(DATA,COUNT); WRITELN(SORT_TABLE,'INITIAL STATE OF THE ARRAY'); PRINT_ARRAY(DATA,COUNT); SORT(DATA,COUNT); WRITELN(SORT_TABLE); WRITELN(SORT_TABLE,'END OF ARRAY DRIVER PROGRAM'); FOR I := 1 TO 26 DO WRITELN; WRITELN(' <<>>'); WRITELN(' >>> DATA WILL BE ON FILE SORT_TAB<<<'); WRITELN(' <<<<<>>>>'); FOR I := 1 TO 13 DO WRITELN; END. (* SORT DRIVER PROGRAM *) FIGURE 5.6 SELECTION SORT INITIAL STATE OF THE ARRAY 44 55 12 42 94 10 6 67 PASS #1 ITEM = 6 6 55 12 42 94 10 44 67 PASS #2 ITEM = 10 6 10 12 42 94 55 44 67 PASS #3 ITEM = 12 6 10 12 42 94 55 44 67 PASS #4 ITEM = 42 6 10 12 42 94 55 44 67 PASS #5 ITEM = 44 6 10 12 42 44 55 94 67 PASS #6 ITEM = 55 6 10 12 42 44 55 94 67 PASS #7 ITEM = 67 6 10 12 42 44 55 67 94 END OF ARRAY DRIVER PROGRAM `6 o"h#N#R#VBb3ZNNjREAD_ARRAY?Hz~*/,HNVN&A-HPHy>Hz?< N`~+"nBQ~,~,09BF@"n2tdB_C@dD~-~."n$n0R@2~/Hy>"n$n0Ad@/ N LN X~0~1`N^,_X> _PNA:SORT_DATPRINT_ARRA?Hz~A/,HNVN&A-HPp=@=n0.nnv~B~B0.rHH@J@f4~CHy"n0.Ad@??<N N bX~D`(~DHy"n0.Ad@??<N XRn`~E~FHyN bXN^,_X> _\NSORT ?Hz~Z/,HNVN&AZ-HPp=@0.S@=@0.nn6~[~[~\=n~]"n0.Ad@=Q~^0.R@=@=n0.nnH~_~_"n0.Ad@0nl$~`~a=n~b"n0.Ad@~c=QRn`~d"n0.Ad@$n0.Ad@2~e"n0.Ad@2~gHyHz?<N @?.?<N Hz\?<N @"n0.Ad@??<N N bX~h"n/ ?.~iN~j~kRn`N^,_X> _\N ITEM = PASS #A`0B1|A01|A01|A>01|~uA#\HyHz?< Nh~vHyHzn?<N @N bX~wHyN bX~xHyHyN6~yHyHz?<N @N bX~zHy?9N~{Hy?9N~|HyN bX~}HyHz?<N @N bX~~p3 yn~~HyN bXRy`><HyHz ?<5N @N bX><HyHz?<2N @N bX><HyHzx?<5N @N bX><p3 y n ><><HyN bXRy`><Hy>N HyN HyN N <<<<<>>>> >>> DATA WILL BE ON FILE SORT_TAB<<< <<>>END OF ARRAY DRIVER PROGRAMINITIAL STATE OF THE ARRAYSELECTION SORTA:SORT_TABLEB9`PByL _0g$_jp"_// HN LJ@fP)J9f" f |` f|` f |` f|`4<G BQB) @ef *:f^&Jrt `e QGtWJBk4G3 J9f g g`> g8 fp@`*S@rG   e gRAQJ9g`tJ)f8a J9g| _0< HyN|#|3|Nu )bJ) g )g )g ) f J9fgHBNu|/ BgHi ?<ANA>3|NAXNu _4` _t6 Bo r aSB`2aNH? \ _r ar a/L? \Nu _r aN _4` _t"x0HgJJjDxvC zp cRЀ`|e W0R"f`6 _4` _t2xJAjDAxvC p0 2H@0RJAfJg<-RBlCSBr aQSCaQN _4v` _46"_JBjtClBSCr aQSBk aQN _v` _60@d C t`C tClBSCr aQSBavQNFALSETRUE _6kfv2_t Cc"4YBv` _6kfv"_t Cc4QBvSBkr a(QSCC" A0 9c^a JgYC`NH L"oA/ N L LNuByL(_ _/ C( g  f,t4(H / /?(?<@NA LJkffNu4(SBraQNu(gN fH ??<NAXLNu f H ??<` f H ??<` f NuHy ` Hy `0< LNREWRITE required prior to WRITE or PUTDisk or directory fullByL _$_"Wp )f)H/ NL4NH/ NLp)`ByL _"WJyf8J)f )f)H/ NL )g)J)fJgBy )g J)fBiNz`zByL _$_"WptvH/ Hya029XL- -fJf^p`4  fJg*`N0eH  bBԂi\(؄iV؄iRԄiNԁRCJ)f  g )f) 0e 9c~Jg&JgDJf 6Höf4N$NHy0<` Hy0<NByL _$_0"Wt )gJ&JRJ)f4H/ HyaP29XL )gJ)f RBBe`ưBe`N&|H/ ?< NA\Hy?< NA\LS@kQ3N Bad digit in number encounteredOverflow during READ of numberByL(_ _/ C (g ( fxJ(f t4($IH / /?(?<?NA LJk,g*fJg  f"J` g  Wf NuJgJ(f P Nu!|Nu4(SBa@J(f8Jg. fJ(f"gr W1Agp f W1A1AQNu(gVJ(fD f&H`?<NAT f?< ?<NAXp LNu fH`?<NATLNuHyv0<` HyR0< LNReset required prior to Read or GetAttempt to read past end-of-file~,GxvGI/??<NM(PRDQNuHyr?< NA\xvI/??<NMPRDQBgNAHy`Hy<`HyV?< NA\Hyn?< NA\ o`>Hy`Hy?< NA\Hy?< NA\ oa.Hyn?< NA\ o /Hyu?< NA\ _p "f/Hy?NA\ _`^"nH .gHy`JkHy`Hy?NA\L/ .fjXt AH ??<NAXLQ/Hy?< NA\t&<'HǏf CgJfr `t20/??<NAX$HG fHy?< NA\ _a6 gz .f >. n` n,n/Hy?< NA\ _`/?<$?<NAX _tv"0 :e^H ??<NAXLYCQNu"*` *** Bus error *** Address error - attempt to reference address *** Attempt to divide by zero *** Value out of range *** Integer overflow *** Error in Called by PROCEDURE FUNCTION MAIN PROGRAM at source line at PC function or procedure compiled w/o DEBUG _ hNVf 0(gr"OD@Hd2S@k "Q` _"yNe HyNN# # .f -|p`-|p nNнf y NStack overruns heap _(N _0/Ho |3LJyJfXNX/#$"|a "_a"|aJyZg y$9BgNA/ ?< NA\Nu09LNu _3JNByLNu *** *** Copyright 1986, CCD and OSS, Inc. 0@B0B             HB@6 2J X D   ( 0"L2 T  0) and (h <> 0) do begin If Rect_Intersect( x0, y0, w0, h0, x, y, w, h) then begin Set_Clip(x, y, w, h); Paint_Color(white); Paint_Rect(x, y, w, h); build_screen; end; Next_Rect(handle, x, y, w, h); end; Show_Mouse; Set_Clip(xm, ym, wm, hm); End_Update; end; (* If we get a message from GEM that our window is now to be the front window, then this routine will bring it to the front. *) Procedure Do_Topped; begin Set_Clip(xm, ym, wm, hm); Bring_To_Front(big_window); end; (* This routine will only clear and redraw a blank window. If you have already placed something on the screen, then you will need to save it somewhere if you wish to see it after a redraw or other type of GEM message. *) Procedure draw_wind; begin Hide_Mouse; Work_Rect(big_window,xm,ym,wm,hm); Set_Clip(xm,ym,wm,hm); Set_Color(white,1000,1000,1000); Paint_Rect(xm,ym,wm,hm); Show_Mouse; cur_x := xm; cur_y := ym + ch; end; (* The following routines process menu item selection. Each one now only performs an ALERT box, but any type of code can be added. *) Procedure item11_proc; begin dummy := Do_Alert('[1][ITEM| 1 - 1][ OK ]',0); end; Procedure item12_proc; begin dummy := Do_Alert('[1][ITEM| 1 - 2][ OK ]',0); end; Procedure item13_proc; begin dummy := Do_Alert('[1][ITEM| 1 - 3][ OK ]',0); end; Procedure item21_proc; begin dummy := Do_Alert('[1][ITEM| 2 - 1][ OK ]',0); end; Procedure item22_proc; begin dummy := Do_Alert('[1][ITEM| 2 - 2][ OK ]',0); end; Procedure item23_proc; begin dummy := Do_Alert('[1][ITEM| 2 - 3][ OK ]',0); end; Procedure item31_proc; begin dummy := Do_Alert('[1][ITEM| 3 - 1][ OK ]',0); end; Procedure item32_proc; begin dummy := Do_Alert('[1][ITEM| 3 - 2][ OK ]',0); end; Procedure item33_proc; begin dummy := Do_Alert('[1][ITEM| 3 - 3][ OK ]',0); end; Procedure item41_proc; begin dummy := Do_Alert('[1][ITEM| 4 - 1][ OK ]',0); end; Procedure item42_proc; begin dummy := Do_Alert('[1][ITEM| 4 - 2][ OK ]',0); end; Procedure item43_proc; begin dummy := Do_Alert('[1][ITEM| 4 - 3][ OK ]',0); end; Procedure item51_proc; begin dummy := Do_Alert('[1][ITEM| 5 - 1][ OK ]',0); end; Procedure item52_proc; begin dummy := Do_Alert('[1][ITEM| 5 - 2][ OK ]',0); end; Procedure item53_proc; begin dummy := Do_Alert('[1][ITEM| 5 - 3][ OK ]',0); end; (* Here is where we find out which item is selected from the titles *) Procedure title1_proc; begin if msg[4] = item11 then item11_proc ELSE if msg[4] = item12 then item12_proc ELSE if msg[4] = item13 then item13_proc; Menu_Normal(a_menu,title1); end; Procedure title2_proc; begin if msg[4] = item21 then item21_proc ELSE if msg[4] = item22 then item22_proc ELSE if msg[4] = item23 then item23_proc; Menu_Normal(a_menu,title2); end; Procedure title3_proc; begin if msg[4] = item31 then item31_proc ELSE if msg[4] = item32 then item32_proc ELSE if msg[4] = item33 then item33_proc; Menu_Normal(a_menu,title3); end; Procedure title4_proc; begin if msg[4] = item41 then item41_proc ELSE if msg[4] = item42 then item42_proc ELSE if msg[4] = item43 then item43_proc; Menu_Normal(a_menu,title4); end; Procedure title5_proc; begin if msg[4] = item51 then item51_proc ELSE if msg[4] = item52 then item52_proc ELSE if msg[4] = item53 then item53_proc; Menu_Normal(a_menu,title5); end; (* So you want to build a DIALOG BOX. Here's how you do it *) Procedure infodial; begin sf := System_Font; Info_Box := New_Dialog(15,0,0,40,18); info_item := Add_DItem(Info_Box,G_Text,None,2,1,36,1,0,$1180); Set_DText(Info_Box,info_item,'Pascal Shell',sf,TE_Center); info_item := Add_DItem(Info_Box,G_Text,None,2,3,36,1,0,$1180); Set_DText(Info_Box,info_item,'by F.P. Nagle',sf,TE_Center); info_item := Add_DItem(Info_Box,G_Text,None,2,5,36,1,0,$1180); Set_DText(Info_Box,info_item,'Copyright (c) 1986',sf,TE_Center); info_item := Add_DItem(Info_Box,G_Text,None,2,9,36,1,0,$1180); Set_DText(Info_Box,info_item,'Portions of this program', sf,TE_Center); info_item := Add_DItem(Info_Box,G_Text,None,2,11,36,1,0,$1180); Set_DText(Info_Box,info_item,'Copyright (c) 1986 OSS & CCD', sf,TE_Center); info_item := Add_DItem(Info_Box,G_Text,None,2,13,36,1,0,$1180); Set_DText(Info_Box,info_item,'Used by permission of OSS.', sf,TE_Center); ok_button := Add_DItem(Info_Box,G_Button,Selectable|Exit_Btn|Default, 15,15,8,2,2,$1180); Set_DText(Info_Box,ok_button,'OK',sf,TE_Center); Center_Dialog(Info_Box); button := Do_Dialog(Info_Box,0); End_Dialog(Info_Box); Menu_Normal(a_menu,Desk_Title); end; (* A menu item has been selected, here we find which one. *) Procedure menu_proc; begin If msg[3] = title1 then title1_proc ELSE if msg[3] = title2 then title2_proc ELSE if msg[3] = title3 then title3_proc ELSE if msg[3] = title4 then title4_proc ELSE if msg[3] = title5 then title5_proc ELSE if msg[3] = Desk_Title then infodial; end; Procedure blnk_wind; begin end; (* GEM has told us that the window was moved, so we must redraw it with the correct NEW size. *) Procedure move_wind; begin Set_WSize(big_window,msg[4],msg[5],msg[6],msg[7]); draw_wind; end; (* GEM has told us that the window has been re-sized, so we need to redraw the NEW size window. *) Procedure size_wind; begin Set_WSize(big_window,msg[4],msg[5],msg[6],msg[7]); draw_wind; end; (* GEM has told us to fill the screen with this window. Note we saved the maximum size in hx, hy, hw, hh when we opened the window initially. *) Procedure full_wind; begin xm := hx; ym := hy; wm := hw; hm := hh; Set_WSize(big_window,hx,hy,hw,hh); draw_wind; end; (* Here's how to draw a "cursor" on the screen. It's only a line! *) Procedure linex; begin Line(cur_x + 2, cur_y - (ch - 3), cur_x + 2, cur_y); end; (* Here's how to position the "cursor" on the screen. *) Procedure pos_cursor; begin cur_x := cur_x + cw; If cur_x > (xm + wm) - cw then begin cur_x := xm; cur_y := cur_y + ch; If cur_y > (hm + ym) then begin cur_y := ym + ch; draw_wind; end end; linex; end; (* The only way to display text on the screen under GEM is to draw the string. We have saved the character value from the key pressed, so here we Draw_String (just one character) to the screen. cur_x and cur_y are the cursor position, and out_char is the value to be drawn. *) Procedure disp_it; begin Draw_String(cur_x,cur_y,out_char); end; (* Here we change the integer value of the key pressed into a character which can be used by the Draw_String command. Before doing anything to the screen though, we Hide_Mouse so we don't lose part of what we want to show. After we get done, we Show_Mouse again. *) Procedure disp_char; begin Hide_Mouse; out_char := chr(key_lo); disp_it; pos_cursor; Show_Mouse; end; (* Because we are Drawing to the screen, if a back space is entered, we need to erase the cursor (line) and move back one, and draw a space to the screen. We also need to check if the cursor is at the far left already. If so, we can't go back any further on this line, so position it at the beginning of the current line. You could also add code to move UP a line and continue back spacing if desired. This is only a demo, so we cut it short here. *) Procedure back_space; begin Hide_Mouse; out_char := chr(32); disp_it; cur_x := cur_x - cw; if cur_x < xm then cur_x := xm; disp_it; linex; Show_Mouse; end; (* We received a carriage return (ENTER), so we need to erase the cursor (line) on the current line. By making the cur_x position off the right side of the screen, we can use the pos_cursor routine to determine the new line position. *) Procedure carr_return; begin Hide_Mouse; out_char := chr(32); disp_it; cur_x := xm + wm + cw; pos_cursor; Show_Mouse; end; Procedure esc_char; begin (* To actually send the escape character to any output you need to use BIOS(3) since GEM will "swallow" all escape characters *) (* bconout(zeron,escn); *) end; Procedure not_used; begin (* This program doesn't use these particular keys, but that does not mean that they aren't available to you for your own usage. Just define the routine that you need to handle your particular needs. *) end; (* Here we check what value we received from the key pressed. I only show a check of the low value, not the entire 16 bit value. In order to determine the use of Function keys and the special Help/Undo etc. keys, you would have to check the high value also, or use the full integer value. *) Procedure check_key; begin CASE key_lo of 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51, 52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71, 72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91, 92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108, 109,110,111,112,113,114,115,116,117,118,119,120,121,122,123, 124,125,126,127 : disp_char; 8 : back_space; 13 : carr_return; 27 : esc_char; 0,1,2,3,4,5,6,7,9,10,11,12,14,15,16,17,18,19,20,21,22,23,24, 25,26,28,29,30,31 : not_used; END; end; (* Here we break the 16 bit integer value into two parts, the high and low values. Since this is a demo, we are only checking for normal ASCII values, excluding Function keys etc.*) Procedure key_process; begin key_lo := what_key & $00FF; key_hi := what_key & $FF00; key_hi := ShR(key_hi,8); check_key; end; (* Once we have received a message from GEM it is up to your program to determine just what to do with it. This routine checks the most used messages, and performs a simple routine within the program to handle each type of message. *) Procedure msg_process; begin Case msg[0] of MN_Selected : If Front_Window = big_window then menu_proc; WM_Sized : If Front_Window = big_window then size_wind; WM_Fulled : If Front_Window = big_window then full_wind; WM_Moved : If Front_Window = big_window then move_wind; WM_Redraw : If msg[3] = big_window then Do_Redraw(msg[3],msg[4],msg[5],msg[6],msg[7]); WM_Topped : Do_Topped; end; end; (* This is the heart of the program. This event routine is repeated over and over until a WM_Closed message is received. If the window is closed, the program ends. You could also use a QUIT command in one of your menus, and force a closed message to cause the program to end. *) Procedure event_rtn; begin event := Get_Event(event_val, 0,0,0, (* No button goodies *) 0, (* No timer *) False,0,0,0,0, (* No mouse rects *) False,0,0,0,0, msg, what_key, (* Key pressed *) dummy,dummy, (* Not used *) dummy,dummy, dummy ); If (event & E_Message) <> 0 then msg_process; If (event & E_Keyboard) <> 0 then key_process; end; (* This is a demonstratin of how to create your own menu. Variables could be of any integer type, so an array would work. I just found it simpler to identify each one uniquely. *) Procedure build_menu; begin a_menu := New_Menu(30,'Pascal Shell'); title1 := Add_MTitle(a_menu,' Title 1 '); title2 := Add_MTitle(a_menu,' Title 2 '); title3 := Add_MTitle(a_menu,' Title 3 '); title4 := Add_MTitle(a_menu,' Title 4 '); title5 := Add_MTitle(a_menu,' Title 5 '); item11 := Add_MItem(a_menu,title1,' Item 1-1 '); item12 := Add_MItem(a_menu,title1,' Item 1-2 '); item13 := Add_MItem(a_menu,title1,' Item 1-3 '); item21 := Add_MItem(a_menu,title2,' Item 2-1 '); item22 := Add_MItem(a_menu,title2,' Item 2-2 '); item23 := Add_MItem(a_menu,title2,' Item 2-3 '); item31 := Add_MItem(a_menu,title3,' Item 3-1 '); item32 := Add_MItem(a_menu,title3,' Item 3-2 '); item33 := Add_MItem(a_menu,title3,' Item 3-3 '); item41 := Add_MItem(a_menu,title4,' Item 4-1 '); item42 := Add_MItem(a_menu,title4,' Item 4-2 '); item43 := Add_MItem(a_menu,title4,' Item 4-3 '); item51 := Add_MItem(a_menu,title5,' Item 5-1 '); item52 := Add_MItem(a_menu,title5,' Item 5-2 '); item53 := Add_MItem(a_menu,title5,' Item 5-3 '); Draw_Menu(a_menu); end; (* Just an alert box at the very beginning of the program. *) Procedure show_progname; begin dummy := Do_Alert('[1][SHELL.PAS|Version 1.0|by F.P.Nagle][ OK ]',0); end; (* I always set up at least one initialize procedure in my programs which is always called once. This sets the initial values I need for titles, etc. Don't rely on ANY compiler to initialize your values for you. Play it safe and do it yourself! *) Procedure init; begin zeron := 0; escn := 27; wind_title := 'Pascal Program Shell'; windtype := G_Name | G_Close | G_Move | G_Size | G_Full; event_val := E_Message | E_Keyboard; Text_Style(Normal); Sys_Font_Size(cw,ch,bw,bh); end; (* This procedure creates and opens YOUR program window! *) Procedure open_wind; begin big_window := New_Window(windtype,wind_title,0,0,0,0); Open_Window(big_window,0,0,0,0); Work_Rect(0,hx,hy,hw,hh); (* Here we save the full size for later use *) Work_Rect(big_window,xm,ym,wm,hm); (* This is the screen work size *) cur_x := xm; (* Initialize cursor positions *) cur_y := ym + ch; blnk_wind; end; (* Every program normally has some cleanup to do when the program ends. This is my End Of Program (eop) processing. Close the window, delete OUR menu etc. *) Procedure eop_processing; begin Close_Window(big_window); Delete_Window(big_window); Erase_Menu(a_menu); Delete_Menu(a_menu); end; (* This is the main program. We initialize GEM and check that we can run. Init_Mouse will always eliminate any Hides we may have remaining from previous programs. It will ALWAYS bring the mouse into view. Once we know the status of the mouse we can then HIDE it within our program. The clear screen command paints a white screen for our program. Just a simple way to give us a clean slate to begin with. We then execute a series of procedures to set up our program. The repeat within this is the main LOOP to continually check for events. When the event is to close the window, then we are DONE! The End Of Program processing will actually Close and Delete our Window and Menus. *) BEGIN If Init_Gem >= 0 then begin Init_Mouse; Hide_Mouse; Clear_Screen; build_menu; show_progname; init; open_wind; Show_Mouse; Repeat event_rtn Until msg[0] = WM_Closed; eop_processing; end; (* After having used Personal Pascal on a few packages about to be released, I felt that the information I had gained could be helpful to others in creating GEM applications for the 520/1040 ST. This SHELL can be expanded into a multitude of applications. If you develop a new idea based on this, and are looking for ways of distributing it, I can be reached at the following: Frank P. Nagle 38346 Logan Drive Fremont, CA 94536-5901 Answering machine (415) 791-5461 MCI Mail - FNAGLE Compuserve - 70505,577 Delphi - FRANKN GEnie - F.NAGLE Good luck with your Personal Pascal work! *) end. PROGRAM SORT_DRIVER(INPUT,OUTPUT,SORT_DAT,SORT_TABLE); (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* SORT ALGORITHM DEMONSTRATION PROGRAM *) (* PROGRAMMER: CHRIS ROBERTSON *) (* ST APPLICATIIONS DEMO *) (* *) (* DESCRIPTION: THIS PROGRAM IS DESIGNED TO BE A DRIVVER *) (* PROGRAM FOR DEMONSTRATION VARIOUS SORTING ALGORITHMS. *) (* IT READS A TEXT FILE OF INTEGERS INTO AN ARRAY AND THEN *) (* PASSES THE ARRAY TO A USER-SUPPLIED SORT ROUTINE. *) (* THE PROCEDURE PRINTARY MAY BE USED BY THE SORT ROUTINE. *) (* TO PRINT THE CURRENT CONTENTS OF THE ARRAY AT VARIOUS *) (* POINTS IN THE SORTING PROCESS, SO TO FURTHER YOUR UNDER- *) (* STANDING OF SORTING. *) (* YOU CAN PRINT THE SORT TABLE THROUGH GEM. VERSION 1.0 *) (**************************************************************) CONST MAX_ARRAY = 100; DISKA1 = 'A:SORT_DAT'; DISKA2 = 'A:SORT_TABLE'; TYPE DATA_ARRAY = ARRAY[0..MAX_ARRAY] OF INTEGER; VAR DATA: DATA_ARRAY; (* DATA ARRAY PASSED TO USER *) I, (* ROUTINE FOR SORTING *) COUNT: INTEGER; (* NUMBER OF INTEGERS IN DATA*) SORT_DAT, SORT_TABLE:TEXT; (* TEXTFILES, ONE WITH DATA, *) (* THE OTHER WITH OUTPUT *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* READ_ARRAY -- READ THE CONTENTS OF THE DATA FILE INTO *) (* THE DATA ARRAYPREPARATORY TO SORTING. *) (* NOTE: IT IS ASSUMED THAT THE DATA IS AN *) (* INDEFINITE NUMBER OF INTEGERS (NOP MORE THAN *) (* MAXARY) STORED ONE PER LINE ON THE DATA FILE *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE READ_ARRAY(VAR DATA:DATA_ARRAY; VAR COUNT:INTEGER); BEGIN (* READ_ARRAY *) RESET(SORT_DAT,DISKA1); COUNT := 0; WHILE NOT EOF(SORT_DAT) AND (COUNT <= MAX_ARRAY) DO BEGIN COUNT := COUNT + 1; READLN(SORT_DAT,DATA[COUNT]) END END; (* READ *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* *) (* PRINT_ARRAY--PRINTS THE CONTENTS OF THE ARRAY SO THAT *) (* THE SORTING PROCESS MAY BE FOLLOWED *) (* *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE PRINT_ARRAY(VAR DATA:DATA_ARRAY; COUNT:INTEGER); CONST PERLINE = 8; (* NUMBER OF DATA VALUES PRINTED *) PLACES = 8; (* ON EACH LINE *) VAR I: INTEGER; BEGIN FOR I := 1 TO COUNT DO IF (I MOD PERLINE = 0) THEN WRITELN(SORT_TABLE,DATA[I]:PLACES) ELSE WRITE(SORT_TABLE,DATA[I]:PLACES); WRITELN END; (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* BUBBLE SORT--THIS WEEK WE WILL WORK WITH BUBBLE SORT *) (* THIS IS THE SIMPLEST TYPE OF EXCHANGE SORT,*) (* THIS VERSION USES A VARIABLE TO KEEP TRACK *) (* OF WHETHER A SWAP HAS OCCURRED IN THE LAST *) (* PASS. IF NOT, THE ARRAY IS SORTED *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) PROCEDURE SORT(VAR DATA:DATA_ARRAY;COUNT:INTEGER); VAR J, (* LOOP INDEX *) TEMP, (* TEMPORTARY VARIABLE FOR SWAPPING *) HIGH: INTEGER; (* LIMIT OF THE COMPARISON RANGE *) SWAP: BOOLEAN; (* WAS A SWAP MADE? TRUE OR FALSE *) BEGIN (* BUBBLE SORT *) WRITELN(SORT_TABLE,'THE FOLLOWING IS A BUBBLE SORT:'); HIGH := COUNT - 1; REPEAT (* UNTIL HIGH = 0 OR NOT SWAP *) SWAP := FALSE; FOR J := 1 TO HIGH DO IF DATA[J] > DATA[J + 1] THEN BEGIN TEMP := DATA[J]; DATA[J] := DATA[J + 1]; DATA[J + 1] := TEMP; SWAP := TRUE END; HIGH := HIGH - 1; (* PRINT OUT THE ARRAY NOW *) WRITELN(SORT_TABLE,'PASS # ',COUNT - HIGH - 1:1); PRINT_ARRAY(DATA,COUNT); UNTIL (HIGH = 0) OR (NOT SWAP) END; (* BUBBLE SORT *) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) (* MAIN PROGRAM--THE USER'S SORT ROUTINE SHOULD BE DECLARED*) (* AS: SORT(VAR DATA: DATA_ARRAY; COUNT:INTEGER); WHERE *) (* DESIRED IT MAY CALL PRINT_ARRAY(DATA,COUNT); *) (* TO PRINT OUT THE CURRENT STATE OF THE ARRAY BEING SORTED*) (*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*) BEGIN (* MAIN *) REWRITE(SORT_TABLE,DISKA2); WRITELN(SORT_TABLE,'BUBBLE SORT'); WRITELN(SORT_TABLE); READ_ARRAY(DATA,COUNT); WRITELN(SORT_TABLE,'INITIAL STATE OF THE ARRAY'); PRINT_ARRAY(DATA,COUNT); SORT(DATA,COUNT); WRITELN(SORT_TABLE); WRITELN(SORT_TABLE,'END OF ARRAY DRIVER PROGRAM'); FOR I := 1 TO 26 DO WRITELN; WRITELN(' <<>>'); WRITELN(' >>> DATA WILL BE ON FILE SORT_TAB<<<'); WRITELN(' <<<<<>>>>'); FOR I := 1 TO 13 DO WRITELN; END. (* SORT DRIVER PROGRAM *) `L6 o"h###,Oc.N//Bg?<JNA BbByN/,HNVAp-HHyrHzl?< N"n BQ09vF@"n 2tdB_C@d6"n $n 0R@2Hyr"n$n 0@/ N |N X`N^,_ _PNA:SORT_DAT/,HNVA-Hp=@=n 0.nnd0.rHH@J@f,Hy"n0.@??<N NX`"Hy"n0.@??<N XRn`HyDNXN^,_ _\N/,HNVA-HHyHz?<N pNX0. S@=@Bnp=@=n0.nnn"n0.@0"n2.RAAQoF"n0.@=Q"n0.@$n0.R@@2"n0.R@@2p=@Rn`0.S@=@HyHzX?<N p0. nS@??<N NX"n/ ?. NX0.J@W0.F@@BdN^,_ _\NPASS # THE FOLLOWING IS A BUBBLE SORT:A0B1|AD01|A01|Ar01|Ad#HyHz\?< NHyHz>>>> >>> DATA WILL BE ON FILE SORT_TAB<<< <<>>END OF ARRAY DRIVER PROGRAMINITIAL STATE OF THE ARRAYBUBBLE SORTA:SORT_TABLEB9"`P"By _0g$_jp"_// H$N4L$J@fP)J9"f" f |` f|` f |` f|`4<G BQB) @ef *:f^&Jrt `e QGtWJBk4G3 J9"f g g`> g8 fp@`*S@rG   e gRAQJ9"g`tJ)f8a J9"g| _0< HyN|#|3|Nu )bJ) g )g )g ) f J9"fgHBNu|/ BgHi ?<ANA>3|NAXNu _4` _t6 Bo r aSB`2aNH? _r ar a/L? Nu _r aN _4` _t"x0HgJJjDxvC zp cRЀ`|e W0R"f`6 _4` _t2xJAjDAxvC p0 2H@0RJAfJg<-RBlCSBr aQSCaQN _4v` _46"_JBjtClBSCr aQSBk aQN _v` _60@d C t`C tClBSCr aQSBavQNFALSETRUE _6kfv2_t Cc"4YBv` _6kfv"_t Cc4QBvSBkr a(QSCC" A0 9c^a JgYC`NH |"oA/ N L |NuBy(_ _/ C( g  f,t4(H / /?(?<@NA LJkffNu4(SBraQNu(gN fH ??<NAXLNu f H ??<` f H ??<` f NuHy ` Hy 0< LNREWRITE required prior to WRITE or PUTDisk or directory fullBy _$_"Wp )f)H/ N4L4NH/ N4Lp)`By _"WJy f8J)f )f)H/ N4L )g)J)fJgBy )g J)fBiNz`zBy _$_"WptvH/ Hy0a0290XL- -fJf^p`4  fJg*`N0eH  bBԂi\(؄iV؄iRԄiNԁRCJ)f  g )f) 0e 9c~Jg&JgDJf 6Höf4N$NHy0<` Hy 0<NBy _$_0"Wt )gJ&JRJ)f4H/ Hy0aP290XL )gJ)f RBBe`ưBe`N&|2H/ ?< NA\Hy ?< NA\LS@kQ3 N Bad digit in number encounteredOverflow during READ of numberBy(_ _/ C (g ( fxJ(f t4($IH / /?(?<?NA LJk,g*fJg  f"J` g  Wf NuJgJ(f P Nu!|Nu4(SBa@J(f8Jg. fJ(f"gr W1Agp f W1A1AQNu(gVJ(fD f&H`?<NAT f?< ?<NAXp LNu fH`?<NATLNuHy0<` Hy0< LNReset required prior to Read or GetAttempt to read past end-of-file _(N _0/Ho |3Jy~fXNX/#4"|La "_a"|SaJyg y49BgNA/ ?< NA\Nu09Nu _3~NByNu *** *** Copyright 1986, CCD and OSS, Inc., *X "^        HB@6 2J X D   ( 0"L2 `  44 55 12 42 94 18 6 67 BUBBLE SORT INITIAL STATE OF THE ARRAY 44 55 12 42 94 18 6 67 THE FOLLOWING IS A BUBBLE SORT: PASS # 1 44 12 42 55 18 6 67 94 PASS # 2 12 42 44 18 6 55 67 94 PASS # 3 12 42 18 6 44 55 67 94 PASS # 4 12 18 6 42 44 55 67 94 PASS # 5 12 6 18 42 44 55 67 94 PASS # 6 6 12 18 42 44 55 67 94 PASS # 7 6 12 18 42 44 55 67 94 END OF ARRAY DRIVER PROGRAM Time and Date Page 1 Time and Date Functions If you are writing an application which needs to find out the current time or date, you can call certain system routines to find out those values (provided the user has set them using the control panel!). The first routine allows you to retrieve the current date: Get date. FUNCTION t_getdate : Integer ; GEMDOS( $2a ) ; Use this call to retrieve the system date, in the following format: bits contents ----- -------- 0- 4 the day of the month (1-31) 5- 8 the month of the year (1-12) 9-15 the number of years since 1980 (0-119) For example, the date February 5, 1986 would be: $0C45 = 6*512 + 2*32 + 5 (0000 1100 0100 0101 in binary) Set date. FUNCTION t_setdate( date : Integer ) : Integer ; GEMDOS( $2b ) ; This call is used to set the date, in the same format given for t_getdate, above. It returns 0, if the date was valid, or a negative error number, otherwise. Get time. Of course, the date alone is not enough. You also need to set and get the current system time. This time value is only accurate to an even number of seconds, however, since there are only 5 bits allocated for returning the current second. FUNCTION t_gettime : Integer ; Use this call to find our the current system time since midnight on the current day. The time is returned as an integer in the following format: bits contents ----- -------- 0- 4 number of two-seconds (0-29) 5-10 number of minutes (0-59) 11-15 number of hours (0-23) Notice that the seconds returned is the number of two-second intervals, so you have to multiply by two to get the number of seconds. This also means that the clock is only accurate to an even number of seconds. Time and Date Page 2 Set time. FUNCTION t_settime( time : integer ) : integer ; GEMDOS( $2d ) ; This call sets the time using the same format as the t_gettime call. It returns 0, if the time was valid, and a negative error number, otherwise. The calls described above are the "GEMDOS" calls for date and time. There are also underlying XBIOS calls to perform the same functions. As usual, we advise that you use the GEMDOS calls whenever possible (unless they have bugs!). Set the system date and time. PROCEDURE settime( date, time : integer ) ; XBIOS( 22 ) ; This call sets the date and time in the intelligent keyboard. The date and time are the same format as the GEMDOS set date and set time calls described above. You should normally use the GEMDOS calls, not this call. Get the system date and time. FUNCTION gettime : Long_Integer ; XBIOS( 23 ) ; This call returns the current date in the high word of the result parameter, and the current time in the low word, both in standard GEMDOS format. PROGRAM name ; CONST {$I gemconst.pas} TYPE {$I gemtype.pas} VAR height : integer ; s : Str255 ; {$I gemsubs.pas} { Text_Height - Set the height in pixels of text, when it is drawn using the Draw_String library call. } PROCEDURE Text_Height( height : integer ) ; TYPE Ctrl_Parms = ARRAY [ 0..11 ] OF integer ; Int_In_Parms = ARRAY [ 0..15 ] OF integer ; Int_Out_Parms = ARRAY [ 0..45 ] OF integer ; Pts_In_Parms = ARRAY [ 0..11 ] OF integer ; Pts_Out_Parms = ARRAY [ 0..11 ] OF integer ; VAR control : Ctrl_Parms ; int_in : Int_In_Parms ; int_out : Int_Out_Parms ; pts_in : Pts_In_Parms ; pts_out : Pts_Out_Parms ; PROCEDURE VDI_Call( cmd, sub_cmd : integer ; nints, npts : integer ; VAR ctrl : Ctrl_Parms ; VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ; VAR pts_in : Pts_In_Parms ; VAR pts_out : Pts_Out_Parms ; translate : boolean ) ; EXTERNAL ; BEGIN pts_in[0] := 0 ; pts_in[1] := height ; VDI_Call(12, 0, 0, 2, control, int_in, int_out, pts_in, pts_out, false); END ; { Get_Height - Get the height in pixels of text, when it is drawn using the Draw_String library call. } FUNCTION Get_Height : integer ; TYPE Ctrl_Parms = ARRAY [ 0..11 ] OF integer ; Int_In_Parms = ARRAY [ 0..15 ] OF integer ; Int_Out_Parms = ARRAY [ 0..45 ] OF integer ; Pts_In_Parms = ARRAY [ 0..11 ] OF integer ; Pts_Out_Parms = ARRAY [ 0..11 ] OF integer ; VAR control : Ctrl_Parms ; int_in : Int_In_Parms ; int_out : Int_Out_Parms ; pts_in : Pts_In_Parms ; pts_out : Pts_Out_Parms ; PROCEDURE VDI_Call( cmd, sub_cmd : integer ; nints, npts : integer ; VAR ctrl : Ctrl_Parms ; VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ; VAR pts_in : Pts_In_Parms ; VAR pts_out : Pts_Out_Parms ; translate : boolean ) ; EXTERNAL ; BEGIN VDI_Call(131, 0, 0, 0, control, int_in, int_out, pts_in, pts_out, false); Get_Height := pts_out[9] ; END ; PROCEDURE wait_button ; VAR msg : Message_Buffer ; junk : integer ; BEGIN junk := Get_Event( E_Button, 1, 1, 1, 0, false, 0, 0, 0, 0, false, 0, 0, 0, 0, msg, junk, junk, junk, junk, junk, junk ) ; junk := Get_Event( E_Button, 1, 0, 1, 0, false, 0, 0, 0, 0, false, 0, 0, 0, 0, msg, junk, junk, junk, junk, junk, junk ) ; END ; BEGIN IF Init_Gem >= 0 THEN BEGIN s := 'nn mm This is a test-- xyzlq' ; s[4] := chr( Get_Height DIV 10 + ord( '0' ) ) ; s[5] := chr( Get_Height MOD 10 + ord( '0' ) ) ; Draw_String( 20, 190, s ) ; wait_button ; FOR height := 2 TO 99 DO BEGIN Text_Height( height ) ; s[1] := chr( height DIV 10 + ord( '0' ) ) ; s[2] := chr( height MOD 10 + ord( '0' ) ) ; s[4] := chr( Get_Height DIV 10 + ord( '0' ) ) ; s[5] := chr( Get_Height MOD 10 + ord( '0' ) ) ; Draw_String( 20, 190, s ) ; wait_button ; END ; Exit_Gem ; END ; END. program typewriter; { one line typewriter program } { by Ron Rautenberg Mar 1986 15 San Juan Dr Salinas, Ca 93901 } CONST { Printer constants for GEMINI 10X } { Software Reset } SW_RESET = '27,64,00'; { Normal print mode - 10 cpi should be done by SW_RESET } NORMPRT = '27,66,01'; { Elongated print - or double wide } ELONGPRT = '27,14,00'; { Condensed print } CONDPRT = '27,15,00'; { To select 8 lines per inch } EIGHTPER = '27,48,00'; { To select 6 lines per inch } SIXPER = '27,50,00'; { Turn underline mode on } UL_ON = '27,45,01'; { Turn underline mode off } UL_OFF = '27,45,00'; { Turn italics on } ITALIC_ON = '27,52,00'; { Italics off } ITALIC_OFF = '27,53,00'; { Bold or Emphasized print - you may use double strike } BOLD_ON = '27,69,00'; { To cancel Bold print } BOLD_OFF = '27,70,00'; MAGIC = '$3ABH'; { To allow install pgm to find constants } MARKER = '99,99,99'; { when an option is not available } CPI_COND = 17; { chars per inch - condensed mode } CPI_NORM = 10; { normal } CPI_ELON = 5; { elongated or double wide } LPI_NORM = 6; { standard lines per inch } LPI_COND = 8; { condensed lines per inch } {$I GEMCONST} TYPE buttons = (cond,pica,elon,bold,ital,unde); {$I GEMTYPE} VAR button : array[cond..unde] of integer; { the type selection buttons } lpi,cpi : integer; boldface,italic,underline : boolean; prt : text; {$I GEMSUBS} { *************************************************************************** } function stoi( s : str255 ) : integer; { convert string s to integer } { assumes s contains only numeric digits } var val,i : integer ; begin val := 0; for i := 1 to Length( s ) do val := val * 10 + ord( s[i] ) - ord ( '0' ); stoi := val; end; { *************************************************************************** } procedure send_control(code:str255); { sends printer control codes based on code string which is a string of decimal digits separated by commas } var str,num_str,control : str255; comma,number,i : integer; begin { of procedure send_control } control := ''; { init control string } code := concat(code,','); { tack a comma on end } str[0] := chr(1); { set length of temp string } loop comma := pos(',',code); { find position of 1st comma } exit if (comma = 0); num_str := copy(code,1,comma-1); { move digits to temp } delete(code,1,comma); { delete 1st number from string } number := stoi(num_str); { convert it to int } str[1] := chr(number); { and back to character } control := concat(control,str); { and stick on end of control str } end; write(prt,control); { send it all to printer } end; { of procedure send_control } { *************************************************************************** } procedure set_printer; { sends controls to set printer to proper config } begin { of procedure set_printer } send_control(SW_RESET); case cpi of { chars per inch } CPI_COND : send_control(CONDPRT); CPI_NORM : send_control(NORMPRT); CPI_ELON : send_control(ELONGPRT); otherwise : ; end; case lpi of { lines per inch } LPI_NORM : send_control(SIXPER); LPI_COND : send_control(EIGHTPER); otherwise : ; end; if boldface then { bold } send_control(BOLD_ON) else if BOLD_ON <> MARKER then { turn off bold in case it was on } send_control(BOLD_OFF); { only if it could have been on } if italic then { ditto italics } send_control(ITALIC_ON) else if ITALIC_ON <> MARKER then send_control(ITALIC_OFF); if underline then { ditto underline } send_control(UL_ON) else if UL_ON <> MARKER then send_control(UL_OFF); end; procedure do_typewriter; const PROMPT1 = 'Ron''s 1 line typewriter'; PROMPT2 = 'Type size Options'; NUM_EDITS = 1; { number of edit lines } BOX_WID = 65; { must be longer than prompt } BOX_HGT = 13; BTN_WID = 8; { 3 * BTN_WID <= BOX_WID - 4 } BTN_HGT = 1; BTN_MARGIN = 12; { distance from side of box to button } { best if 4*BTN_MARGIN + 3*BTN_WID = BOX_WID } var the_box : dialog_ptr; { name of the box } prompt_item, { name of the prompt } ok,help,quit, { the exit buttons } pushed, { which one the user exited with } i : integer; { loop variable } the_button : buttons; x,y : integer; name : string[10]; line : array[1..NUM_EDITS] of integer; { name of the edit lines } template,valid,init : array[1..NUM_EDITS] of str255; entry : array[1..NUM_EDITS] of str255; begin Init_Mouse; { create the box } the_box := New_Dialog(NUM_EDITS + 13,0,0,BOX_WID,BOX_HGT); { add the prompt } prompt_item := Add_Ditem(the_box,g_text,None,0,1,BOX_WID,1,0, 256*BLACK+128); Set_Dtext(the_box,prompt_item,PROMPT1,System_font,TE_Center); (* prompt_item := Add_Ditem(the_box,g_text,None,0,3,BOX_WID,1,0, 256*BLACK+128); Set_Dtext(the_box,prompt_item,PROMPT2,System_font,TE_Center); *) { add selection buttons } for the_button := cond to elon do begin x := 15; y := ord(the_button) + 3; case the_button of cond : name := 'Condensed'; pica : name := 'Pica'; elon : name := 'Elongated'; end; { case } button[the_button] := Add_Ditem(the_box,G_button,Selectable | Radio_Btn, x,y,12,1,0,256*BLACK+128); Set_Dtext(the_box,button[the_button],name,System_font,TE_Center); end; for the_button := bold to unde do begin x := 40; y := (ord(the_button)-3) + 3; case the_button of bold : name := 'Bold Face'; ital : name := 'Italics'; unde : name := 'Underline'; end; button[the_button] := Add_Ditem(the_box,G_button,Selectable , x,y,12,1,0,256*BLACK+128); Set_Dtext(the_box,button[the_button],name,System_font,TE_Center); end; { initialize PICA button } Obj_SetState(the_box,button[pica],Selected,False); { add the exit buttons } ok := Add_Ditem(the_box,G_button,Selectable | Exit_Btn | Default, BTN_MARGIN,NUM_EDITS+9,BTN_WID,BTN_HGT, 0,0); Set_Dtext(the_box,ok,'OK',System_font,TE_Center); { help := Add_Ditem(the_box,G_button,Selectable | Exit_Btn, (BOX_WID-BTN_WID)DIV 2,NUM_EDITS+9,BTN_WID,BTN_HGT, 0,0); Set_Dtext(the_box,help,'HELP',System_font,TE_Center); } quit := Add_Ditem(the_box,G_button,Selectable | Exit_Btn, BOX_WID-BTN_WID-BTN_MARGIN,NUM_EDITS+9,BTN_WID,BTN_HGT, 0,0); Set_Dtext(the_box,quit,'QUIT',System_font,TE_Center); { set up template and validation strings } for i := 1 to NUM_EDITS do begin template[i] := '____________________________________________________________'; valid[i] := 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX'; line[i] := Add_Ditem(the_box,G_Ftext,None,1,7+i,BOX_WID,1,0, 256*BLACK+128); end; repeat { add the edit lines } for i := 1 to NUM_EDITS do begin init[i] := ''; Set_Dedit(the_box,line[i],template[i],valid[i],init[i], System_font,TE_Center); end; Center_dialog(the_box); { display it } pushed := Do_Dialog(the_box,line[1]); { erase it } End_dialog(the_box); { get the users entries } if pushed = ok then begin Obj_SetState(the_box,ok,Normal,False); for i := 1 to NUM_EDITS do begin Get_Dedit(the_box,line[i],entry[i]); end; boldface := FALSE; italic := FALSE; underline := FALSE; { which buttons were selected } for the_button := cond to unde do begin if (Obj_State(the_box,button[the_button]) & Selected) <> 0 then case the_button of cond : begin lpi := LPI_COND; cpi := CPI_COND; end; pica : begin lpi := LPI_NORM; cpi := CPI_NORM; end; elon : begin lpi := LPI_NORM; cpi := CPI_ELON; end; bold : boldface := TRUE; ital : italic := TRUE; unde : underline := TRUE; end; { print it all } end; for i := 1 to NUM_EDITS do begin set_printer; writeln(prt,entry[i]); end; end; until pushed = quit; end; { of procedure do_typewriter } { *************************************************************************** } { main program } BEGIN IF Init_Gem >= 0 THEN BEGIN rewrite(prt,'lst:'); do_typewriter; Exit_Gem ; END ; END. { Thats all folks }