fouts@AMES-NAS.ARPA (07/27/86)
This is the last part of my OSS Pascal demo. It is the file
strval.pas. I did not write it, but got it from the OSS PASCAL
buletin board.
Place strval.pas, peekpoke.pas, and pager.pas in the same folder and
compile pager.pas, using the GEM option on the compiler.
----- CUT HERE -----
{***
* Floating Point Conversion routines.
* From Real to String and String to Real
*
* By Kevin L. McGrath
***}
PROCEDURE Str(Value: Real; VAR St: String);
{* Notes:
* This routine is only accurate up to 9 digits becuase of the LongTrunc.
* It HAD rounding errors, but they are now fixed (with the LongTrunc)
*
* O.S.S. Pascals Floating Point Format:
* This is just a guess, but here goes...
* One byte of exponent biased by 128 to give a +38 to -38 range.
* Fourty bits of mantissa to give 11 digits of accuracy, One bit sign.
* Most floating points are normalized to the left, with the point between
* the most significant bit of the mantissa and the second most, so I think
* this is two. To find out, just plug out a routine that has a pointer
* to a real, coerce's it into a pointer to a record structure of byte like
* this:
* Record
* Exponent: Byte;
* MantissaOne: Long;
* MantissaTwo: Long;
* MantissaThree: Long;
* End;
* then you can extract the exponent and mantissa just by doing a
* "Ptr.Exponent" or somethin like that. Well, I haven't had time to get
* that fancy with this, but I have used this routine and am sure it works.
* Hope you guys at O.S.S. can vert it to some kind of normal ASM function!
* Good Luck... (Nice Compiler)
* Call me if there are any probs, dig?
*}
Const
Max_Digits = 09;
Max_Exponent = 38;
Var
Val: Real;
TempInt,
Sig_Digits,
Dec_Exp,
I: Integer;
Digits: String;
Begin
Val := Abs(Value);
Dec_Exp := 0;
{* Get the exponent without Natural Log (Ln doesn't seem to work fer me) *}
If (Val < 1) And (Val > 0) Then
Begin
For I := 0 To (Max_Exponent-1) Do
If (Val < (1/PwrOfTen(I))) And (Val >= (1/PwrOfTen(I+1))) Then
Dec_Exp := -(I+1);
Val := Val * PwrOfTen(Abs(Dec_Exp)-1);
End
Else
Begin
For I := 0 To (Max_Exponent-1) Do
If (Val >= PwrOfTen(I)) And (Val < PwrOfTen(I+1)) Then
Dec_Exp := I;
Val := Val / PwrOfTen(Dec_Exp+1);
End;
{ Get decimal digits by stripping }
Digits := '';
St := '';
For I := Max_Digits DownTo 1 Do
Begin
{ Take care of rounding problems }
Val := Long_Trunc(Val*PwrOfTen(I)+0.5)/PwrOfTen(I);
Val := Val*10.0;
Digits := ConCat(Digits,Chr(48+Trunc(Val)));
Val := Val-Trunc(Val);
{ Take care of rounding problems }
Val := Long_Trunc(Val*PwrOfTen(I)+0.5)/PwrOfTen(I);
End;
{ Format and put result in St }
{ Put sign }
If Value < 0 Then St := '-';
{ Compute significant digits }
Sig_Digits := Max_Digits;
I := Max_Digits - 1;
While ((Digits[I]='0') And (I>0)) Do
Begin
Sig_Digits := Sig_Digits - 1;
I := I - 1;
End;
Sig_Digits := Sig_Digits - 1;
{ Put in exponential or non-exonential }
If ((Sig_Digits-Max_Digits)<=Dec_Exp) And (Dec_Exp<=Max_Digits) Then
Begin
{ Non-exponental form }
{ Put decimal point and leading zeros for numbers with negative exponents }
If Dec_Exp < 0 Then
Begin
St := ConCat(St,'.');
For I := 1 To -Dec_Exp-1 Do
St := ConCat(St,'0');
End;
{ Put significant digits }
St := ConCat(St,Digits[1]);
For I := 1 To Sig_Digits-1 Do
Begin
If Dec_Exp = 0 Then
St := ConCat(St,'.');
St := ConCat(St,Digits[I+1]);
Dec_Exp := Dec_Exp - 1;
End;
{ Put trailing zeros }
While Dec_Exp > 0 Do
Begin
St := ConCat(St,'0');
Dec_Exp := Dec_Exp - 1;
End;
End
Else
Begin
{ Exponental form }
{ Put first digit }
St := ConCat(St,Digits[1]);
{ Put decimal point }
If Sig_Digits > 1 Then
St := ConCat(St,'.');
{ Put remaining significant digits }
For I := 1 To (Sig_Digits - 1) Do
St := ConCat(St,Digits[I+1]);
{ Put the 'E' for the exponent }
St := ConCat(St,'E');
{ Put exponents sign }
If Dec_Exp >= 0 Then
St := ConCat(St,'+')
Else
Begin
St := ConCat(St,'-');
Dec_Exp := Abs(Dec_Exp);
End;
{ Put the exponent }
If Dec_Exp >= 10 Then
Begin
St := ConCat(St,Chr(48+(Dec_Exp Div 10)));
St := ConCat(St,Chr(48+Dec_Exp-((Dec_Exp Div 10) * 10)));
End
Else
Begin
St := ConCat(St,'0');
St := ConCat(St,Chr(48+Dec_Exp));
End;
End;
End;
FUNCTION Val( St: String): Real;
Const
Max_Digits = 09;
Var
Dec_Exp,
Exp_Value,
Count,
Position: Integer;
Chr: Char;
Result: Real;
Dec_Sign,
Exp_Sign: Boolean;
PROCEDURE Add_Digit;
Begin
Result := (Result * 10) + (Ord(Chr) & $0F);
End;
PROCEDURE Read_Chr;
Begin
Position := Position + 1;
If Position > Length(St) Then
Chr := 'X'
Else
Chr := St[Position];
End;
Begin
Position := 0;
Read_Chr;
Result := 0.0;
{ Get sign }
Dec_Sign := False;
If Chr = '+' Then Read_Chr;
If Chr = '-' Then
Begin
Read_Chr;
Dec_Sign := True;
End;
{ Get digits to left of decimal point }
Dec_Exp := 0;
Count := Max_Digits;
While ('0' <= Chr) And (Chr <= '9') Do
Begin
If Count > 0 Then
Begin
Add_Digit;
Count := Count - 1;
End
Else
Dec_Exp := Dec_Exp + 1;
Read_Chr;
End;
{ Get digits to the right of decimal point }
If Chr = '.' Then
Begin
Read_Chr;
While ('0' <= Chr) And (Chr <= '9') Do
Begin
If Count > 0 Then
Begin
Add_Digit;
Dec_Exp := Dec_Exp - 1;
Count := Count - 1;
End;
Read_Chr;
End;
End;
{ Get exponent part }
If (Chr = 'E') Or (Chr = 'e') Then
Begin
Read_Chr;
Exp_Sign := False;
If Chr = '+' Then Read_Chr;
If Chr = '-' Then
Begin
Read_Chr;
Exp_Sign := True;
End;
Exp_Value := 0;
If ('0'<=Chr) And (Chr<='9') Then Exp_Value := (Ord(Chr) & $0F)*10;
Read_Chr;
If ('0'<=Chr) And (Chr<='9') Then Exp_Value := Exp_Value+(Ord(Chr) & $0F);
If (Chr = 'X') And (Exp_Value >= 10) Then Exp_Value := Exp_Value Div 10;
If Exp_Sign Then
Dec_Exp := Dec_Exp - Exp_Value
Else
Dec_Exp := Dec_Exp + Exp_Value;
End;
{ Multiply or divide Result by power of 10 specified by Dec_Exp }
If Dec_Exp > 0 Then
Result := Result * PwrOfTen(Dec_Exp)
Else
Result := Result / PwrOfTen(Abs(Dec_Exp));
If Dec_Sign Then Result := -Result;
Val := Result;
End;fouts@AMES-NAS.ARPA (07/27/86)
This is pager.pas, it's the third part of my OSS Pascal demo. Place this,
strval.pas, and peekpoke.pas in the same file, and compile pager.pas.
- ----- CUT HERE -----
{
pager.pas is a demonstration of the GEM interface, as exercised
by OSS Personal Pascal. Pager.pas is in the public domain, and
may be used for any purpose, so long as the author is acknowledged.
Martin Fouts
}
PROGRAM pager;
CONST
{$I GEMCONST.PAS}
SUPER_MODE = $20; { GEMDOS call number to enter supervisor mode }
Max_Wind = 10;
Delay = 10000; { Time between timeouts (in milliseconds) }
Max_Char = 80;
TYPE
{$I GEMTYPE.PAS}
Wind_No = 1..Max_Wind;
{ Ubuffer = packed array [1..Max_Char] of char;}
UBuffer = string [255];
UTPtr = ^Utext;
Utext = Record
Prev, Next : UTPtr;
Uline : Ubuffer;
End;
UFile = packed File of char;
Wind_Rec = Record
Handle : integer; { GEM Handle from New_Window }
InUse : boolean; { True if this record is in use }
Title : string; { Contents of title bar }
Full : boolean; { True if last click on full made full window }
Ufp : UFile; { File associated with window }
Ufirst : UTPtr; { Start of data from this file }
Ulast : UTPtr; { End of data from this file }
UCurrent : UTPtr; { First line of current screen }
UCharNo : integer; { First character of current screen (zero based )}
ULineNo : integer; { First line of current screen }
UWide : integer; { Width of widest line in this file }
UHigh : integer; { Number of lines read in }
LWide : integer; { Number of characters wide }
LHigh : integer; { Number of characters high }
X_percent : 0..1000; { Position of slider, initially 0 }
Y_percent : 0..1000; { Position of slider, initially 0 }
Ended : boolean; { True if EOF(Ufp) has occured }
{ Current coordinates }
windx, windy, windw, windh : integer;
{ Last coordinates less than full size }
smallx, smally, smallw, smallh : integer;
{ Coordinates of working space }
workx, worky, workw, workh : integer;
end;
Wind_Array = array[Wind_No] of Wind_Rec;
VAR
wind : Wind_Array; { Track the windows we are using }
running : boolean; { Set to false to quit execution }
pathname : string; { Default search path for file opens }
filename : string; { Filename returned by select file }
mymenu : Menu_Ptr; { Pointer to menu for this program }
mytitle : Integer; { Pointer to first (only) title bar in menu }
Item1 : Integer; { First (open) item in File menu }
Item2 : Integer; { Second (close) item in File menu }
Item3 : Integer; { Third (quit) item in File menu }
B_Left : Integer; { Status of Left Button, 0 = up, 1 = down }
InWindow : Boolean; { True if in the front (active) window }
Timeouts : Integer; { Count the number of timeouts }
cw, ch : Integer; { Width and Height of a character }
bw, bh : Integer; { Width and Height of a box around a char }
ticks : long_integer; { Timer count at start of program }
mouse_init : Boolean; { True if mouse has been initialized }
menu_init : Boolean; { True if menu has been initialized }
{$I GEMSUBS.PAS}
{$I PEEKPOKE.PAS}
{$I STRVAL.PAS}
FUNCTION min (x, y : integer) : integer;
BEGIN
if (x < y)
THEN min := x
ELSE min := y;
END;
FUNCTION max (x, y : integer) : integer;
BEGIN
if (x > y)
THEN max := x
ELSE max := y;
END;
PROCEDURE Update_Slides(VAR wind : Wind_Rec);
VAR
XSize : Integer;
YSize : Integer;
FUNCTION Kof(X,Y:integer) : integer;
{ Returns X div Y, normalized to the range 0-1000,
excess values are 'clipped' to the endpoints of the range }
VAR
Ftemp1 : real;
Ftemp2 : real;
Itemp : Integer;
BEGIN
{ These calculations are done this way to avoid integer overflow
and preserve decimal places. }
IF (Y = 0) { Avoid divide by zero errors }
THEN Kof := 0
ELSE
BEGIN
Ftemp1 := X;
Ftemp2 := Y;
ITemp := Trunc((Ftemp1 / Ftemp2) * 1000.0);
Kof := MAX(MIN(1000,Itemp),1);
END;
END;
BEGIN
WITH wind DO
BEGIN
work_rect(handle,WorkX,WorkY,WorkW,WorkH);
sys_font_size(cw,ch,bw,bh);
LWide := WorkW div cw; { convert pixel size to character size }
LHigh := WorkH div ch;
{ Calculate position and size of horizontal elevator }
X_Percent := Kof(UCharNo+1,UWide);
XSize := Kof(LWide,UWide);
{ Calculate position and size of vertical elevator }
IF (Ended)
THEN
BEGIN { Actually know length of file, so use real values }
Y_Percent := Kof(UlineNo,Uhigh);
YSize := Kof(LHigh,UHigh);
END
ELSE
BEGIN { Don't know length, allow one page of end room }
Y_Percent := Kof(UlineNo,(Uhigh+Lhigh));
YSize := Kof(LHigh,(UHigh+Lhigh));
END;
{ Now set the elevator position and size }
Wind_Set(handle,WF_HSlSize,XSize,0,0,0);
Wind_Set(handle,WF_VSlSize,YSize,0,0,0);
Wind_Set(handle,WF_HSlide,X_percent,0,0,0);
Wind_Set(handle,WF_VSlide,Y_percent,0,0,0);
END;
END;
FUNCTION super( sp: long_integer) : long_integer;
GEMDOS($20);
FUNCTION Get_timer : long_integer;
VAR
ssp : long_integer;
BEGIN
ssp := super(0);
Get_timer := 5*lpeek($4ba);
ssp := super(ssp);
END;
PROCEDURE Get_String(VAR Ufd:Ufile; VAR Uline:Ubuffer;
VAR Ended : boolean);
{ Read a carriage return terminated string and return it with
the carriage return replaced by null }
VAR
i : integer;
c : char;
BEGIN
i := 0;
c := chr(0);
ended := false;
WHILE (i < Max_Char) AND (c <> chr(13)) AND (NOT Ended) DO
BEGIN
c := Ufd^;
i := i + 1;
Uline[i] := c;
Ended := Eof(Ufd);
IF NOT Ended THEN get(Ufd);
END;
Ended := Eof(Ufd);
IF NOT Ended THEN get(Ufd); { Skip the linefeed }
Uline[0] := chr(i);
If i = 0 THEN i := 1;
Uline[i] := chr(0);
END;
PROCEDURE Init_Menu;
{ Set up the Menu. GEM Requires all titles first, then all items
IN ORDER within Title. }
BEGIN
menu_init := true;
mymenu := New_Menu(10, ' About Pager');
mytitle := Add_MTitle(mymenu,' FILE ');
Item1 := Add_MItem(mymenu,mytitle,' Open ');
Item2 := Add_MItem(mymenu,mytitle,' Close ');
Item3 := Add_MItem(mymenu,mytitle,' Quit ');
Draw_Menu(mymenu);
END;
FUNCTION Match_Window(new_handle : integer) : integer;
{ Find the window record for the specified handle. Return 0 if not found }
VAR
i, n : Integer;
BEGIN
n := 0;
FOR i := 1 to Max_Wind DO
IF (Wind[i].handle = new_handle) THEN n := i;
Match_Window := n;
END;
PROCEDURE Redraw_Text(handle,x,y,w,h:integer);
VAR
i : integer;
lines : integer;
lineno : integer;
ptr : UTPtr;
finished : boolean;
BEGIN
i := Match_Window(handle);
Set_Clip(x,y,w,h);
WITH Wind[i] DO
BEGIN
Work_Rect(handle,x,y,w,h);
lines := h div ch;
ptr := Ucurrent;
lineno := 1;
finished := false;
WHILE (lineno <= lines) AND (NOT finished) DO
BEGIN
IF (Ptr = nil)
THEN
BEGIN
IF (NOT Ended) THEN
BEGIN
New(ptr);
Get_String(Ufp,Ptr^.Uline,Ended);
Draw_String(cw*(-UCharNo),ch*lineno,Ptr^.Uline);
Uhigh := Uhigh + 1;
Uwide := MAX(UWide,Length(Ptr^.Uline));
ptr^.prev := Ulast;
Ulast^.next := ptr;
Ulast := ptr;
ptr^.next := nil;
ptr := ptr^.next;
END;
finished := Ended;
END
ELSE
BEGIN
Draw_String(cw*(-UCharNo),ch*lineno,Ptr^.Uline);
Ptr := Ptr^.next;
END;
lineno := lineno + 1;
END;
END;
Update_Slides(wind[i]);
END;
FUNCTION Free_Window : integer;
{ Find an unused window. Returns 0 if none available. }
VAR
i : Integer;
found : Boolean;
BEGIN
found := False;
i := 1;
WHILE (i < Max_wind) AND (NOT found) DO
BEGIN
found := NOT wind[i].InUse;
i := i + 1;
END;
IF found
THEN Free_Window := i - 1
ELSE Free_Window := 0;
END;
PROCEDURE Make_Window(VAR wind : Wind_Rec);
{ Build the data structures for a window }
BEGIN
WITH wind DO
BEGIN
InWindow := false;
B_Left := 0;
title := filename;
handle := New_Window(G_All,title,0,0,0,0);
full := true;
InUse := true;
UWide := 0;
UHigh := 0;
X_percent := 0;
Y_percent := 0;
ULineNo := 0;
Ufirst := nil;
ULast := nil;
UCurrent := nil;
UCharNo := 0;
Ended := False;
END;
END;
PROCEDURE Draw_Window(VAR wind : Wind_Rec);
{ Draw the window on the screen }
VAR
x, y, w, h : Integer;
BEGIN
WITH wind DO
BEGIN
Begin_Update;
Hide_Mouse;
Open_Window(handle,0,0,0,0);
Set_Window(handle);
Bring_To_Front(handle);
Work_rect(handle,workx,worky,workw,workh);
Set_Clip(workx,worky,workw,workh);
smallx := workx;
smally := worky;
smallw := workw div 2;
smallh := workh div 2;
Update_Slides(wind);
Show_Mouse;
End_Update;
END;
END;
PROCEDURE Update_window(handle : integer);
VAR
x, y, w, h : Integer;
x0, y0, w0, h0 : Integer;
BEGIN
Begin_Update;
Hide_Mouse;
Work_Rect(handle,x0,y0,w0,h0);
First_Rect(handle,x,y,w,h); { Locate an area in need of update }
WHILE (w <> 0) OR (h <> 0) DO
BEGIN { For each area of the window }
Paint_Rect(x-x0,y-y0,w,h); { need to convert absolute to }
Redraw_Text(handle,x,y,w,h);
Next_Rect(handle,x,y,w,h); { Find another rectangle to test }
END;
Show_Mouse;
End_Update;
END;
PROCEDURE prev_window(VAR wind : Wind_rec; lines : integer);
VAR
lineno : integer;
ptr : UTPtr;
BEGIN
WITH wind DO
BEGIN
work_rect(handle,workx,worky,workw,workh);
Paint_Rect(0,0,workw,workh);
ptr := UCurrent;
IF (ptr <> NIL) THEN
WHILE (lines > 0) AND (ptr^.prev <> nil) DO
BEGIN
lines := lines - 1;
ULineNo := ULineNo - 1;
ptr := ptr^.prev;
END;
UCurrent := ptr;
Update_window(handle);
END;
END;
PROCEDURE next_window(VAR wind : Wind_rec; lines : integer);
VAR
lineno : INTEGER;
Ptr : UTPtr;
BEGIN
WITH wind DO
BEGIN
work_rect(handle,workx,worky,workw,workh);
Paint_Rect(0,0,workw,workh);
lineno := 1;
ptr := Ucurrent;
IF (ptr <> NIL) THEN
WHILE (lineno <= lines) AND (Ptr^.next <> nil) DO
BEGIN
ptr := ptr^.next;
lineno := lineno + 1;
ULineNo := ULineNo + 1;
END;
UCurrent := ptr;
Update_Window(handle);
END;
END;
PROCEDURE fill_window(VAR wind : Wind_rec);
VAR
lines : INTEGER;
lineno : INTEGER;
Ptr : UTPtr;
BEGIN
WITH wind DO
BEGIN
lines := LHigh;
reset(Ufp,filename); { Open the file for reading }
lineno := 1;
WHILE (lineno <= lines) AND (NOT ended) DO
BEGIN
new(Ptr);
If (UFirst = nil) THEN UFirst := Ptr;
Ptr^.Prev := Ucurrent;
IF (UCurrent <> Nil) THEN Ucurrent^.Next := Ptr;
Ptr^.Next := Nil;
UCurrent := Ptr;
Get_String(Ufp,Ptr^.Uline,Ended);
lineno := lineno + 1;
UHigh := UHigh + 1;
UWide := MAX(UWide,Length(Ptr^.Uline));
END;
ULast := UCurrent;
UCurrent := UFirst;
END;
UPdate_Slides(wind);
END;
FUNCTION Init_Window : Boolean;
{ Attempt to create a new window and open a file. Returns false if aborted by
the filename dialog, or if there are no windows left }
VAR
n : Integer;
temp : Boolean;
i : integer;
trying : Boolean;
PROCEDURE IO_CHECK(flag:boolean); EXTERNAL;
FUNCTION IO_RESULT : INTEGER; EXTERNAL;
BEGIN
n := Free_Window; { Find a window record for this window }
temp := n > 0;
IF NOT temp { No window available, so fail }
THEN n := Do_Alert('[3][No More Windows][ OK ]',1)
{ Have a window, so look for a file spec }
ELSE
BEGIN
trying := Get_In_file(pathname,filename);
WHILE Trying DO
BEGIN { Try to open the specified file }
IO_Check(false); { We want to handle I/O problems }
reset(wind[n].Ufp,filename);
i := IO_Result;
IO_check(true);
if (i = 0)
THEN
BEGIN
temp := true;
trying := false;
END
ELSE
BEGIN
i := Do_Alert('[3][Open failed!][ OK ]',1);
temp := Get_In_file(pathname,filename);
trying := temp;
END;
END;
END;
IF temp THEN { Set up the window }
BEGIN
Make_Window(wind[n]);
Draw_Window(wind[n]);
Fill_Window(wind[n]);
END;
Init_Window := temp;
END;
PROCEDURE Start_up;
{ Initialize the mouse and the menu and open the first window }
VAR
i : integer;
x, y, w, h : Integer;
BEGIN
{ First, give user a chance to bag the program }
i := Do_Alert(
'[1][ File Pager | A Program by Martin Fouts ][ Ready | Cancel ]',2);
running := (i = 1);
pathname := 'A:*.*';
mouse_init := false;
menu_init := false;
IF running THEN
BEGIN
Init_Menu;
Init_Mouse;
mouse_init := true;
Sys_Font_Size(cw,ch,bw,bh);
Paint_Color(White);
running := Init_Window;
timeouts := 0;
ticks := Get_timer; { What time is it? }
END;
END;
PROCEDURE Process;
{ Where the work gets done. Handle a keyboard or message event }
VAR
i : integer;
message : Message_Buffer; { These are all returned by get_event }
key : Integer;
bcnt : Integer;
bstate : Integer;
mx : Integer;
my : Integer;
kbd_state : Integer;
Cur_X, Cur_Y, Cur_W, Cur_H : Integer;
PROCEDURE Do_Message; { Process a Message event }
PROCEDURE Close_It(n:Integer); { Close a window }
VAR
windno, x0, y0, w0, h0 : Integer;
BEGIN
Close_Window(n);
Delete_Window(n);
Set_Window(Front_Window);
Work_Rect(Front_Window, x0, y0, w0, h0);
Set_Clip(x0, y0, w0, h0);
windno := Match_Window(n);
WITH Wind[windno] DO
BEGIN
InUse := False;
Close(Ufp);
IF (UFirst <> Nil) THEN
WHILE (Ufirst <> Nil) DO
BEGIN
UCurrent := Ufirst^.Next;
Dispose(Ufirst);
UFirst := UCurrent;
END;
END;
END;
PROCEDURE Do_Selection; { Process a menu selection event }
VAR
temp : integer;
PROCEDURE Menu_Open; { File Menu Open Item selected }
VAR
temp : boolean;
BEGIN
temp := Init_Window; { Open A Window }
END;
PROCEDURE Menu_Close; { File Menu Close Item selected }
BEGIN
Close_It(Front_Window);
END;
PROCEDURE Menu_Quit; { File Menu Quit Item selected }
VAR { Use an alert to verify the Quit }
temp : integer;
BEGIN
temp :=
Do_Alert('[3][ Do you really want to Quit? ][ Quit | Continue ]',2);
running := (temp <> 1); { Return FALSE to Quit! }
END;
BEGIN
Menu_Normal(mymenu,message[3]); { Turn off menu highlight }
IF (message[3] = 3) THEN { Special case, the INFO box }
temp := Do_Alert('[1][A Sample Program][ OK ]',0)
ELSE IF (message[4] = item1) THEN Menu_Open
ELSE IF (message[4] = item2) THEN Menu_Close
ELSE IF (message[4] = item3) THEN Menu_Quit;
END; { Procedure Do_Selection }
PROCEDURE Do_Redraw; { Handle a redraw message }
VAR
temp, x, y, w, h : Integer;
x0, y0, w0, h0 : Integer;
BEGIN
Begin_Update; { Prevent interference }
Hide_Mouse; { Keep the mouse out of the way }
temp := Get_Window; { Remember the active window }
Set_Window(message[3]); { Make the updated window active }
Work_Rect(message[3],x0,y0,w0,h0); { Find out about it }
Set_Clip(x0,y0,w0,h0);
First_Rect(message[3],x,y,w,h); { Locate an area in need of update }
WHILE (w <> 0) OR (h <> 0) DO
BEGIN { For each area of the window }
IF Rect_Intersect(message[4],message[5],message[6],message[7],
x,y,w,h) THEN
BEGIN { Find the area which must be updated and do so }
Paint_Rect(x-x0,y-y0,w,h); { need to convert absolute to }
Redraw_Text(message[3],x,y,w,h);
END; { relitive coordinates for Paint }
Next_Rect(message[3],x,y,w,h); { Find another rectangle to test }
END;
Show_Mouse; { Make the mouse active again }
End_Update; { Allow GEM activity again }
Set_Window(temp); { Restore the active window }
Work_Rect(temp,x0,y0,w0,h0);
Set_Clip(x0,y0,w0,h0); { And set it up as the i/o port }
END;
PROCEDURE Do_Newtop; { Bring a new window to the top }
BEGIN
Bring_To_Front(message[3]);
Set_Window(message[3]);
END;
PROCEDURE Do_Close; { Close a window (and it's file) }
BEGIN
Close_It(message[3]);
END;
PROCEDURE Do_Fulled; { Handle a click on the full box }
var
n, x, y, w, h : integer;
BEGIN
n := Match_Window(message[3]); { Find the window }
WITH wind[n] DO
BEGIN
IF Wind[n].Full { If already full then shrink the window }
THEN
BEGIN
Set_WSize(handle, smallx, smally, smallw, smallh);
windx := smallx;
windy := smally;
Windw := smallw;
windh := smallh;
END
ELSE
BEGIN { If small make largest size possible }
Wind_Get(handle,WF_FullXYWH,windx,windy,windw,windh);
Set_Wsize(handle,windx,windy,windw,windh);
END;
Full := NOT Full; { Swap the full mode }
Update_Slides(wind[n]);
END;
END;
PROCEDURE Do_Arrowed; { Handle an arrow being clicked }
VAR
n : integer;
PROCEDURE Page_up;
BEGIN
prev_window(wind[n],wind[n].Lhigh);
END;
PROCEDURE Page_down;
BEGIN
next_window(wind[n],wind[n].Lhigh);
END;
PROCEDURE Row_up;
BEGIN
WITH wind[n] DO
BEGIN
if (Ucurrent <> nil) THEN
if (Ucurrent^.prev <> nil) THEN
BEGIN
Ucurrent := Ucurrent^.prev;
update_window(handle);
ULineno := ULineno - 1;
END;
END;
END;
PROCEDURE Row_down;
BEGIN
WITH wind[n] DO
BEGIN
if (Ucurrent <> nil) THEN
if (Ucurrent^.next <> nil) THEN
BEGIN
Ucurrent := Ucurrent^.next;
update_window(handle);
ULineno := ULineno + 1;
END;
END;
END;
PROCEDURE Page_left;
BEGIN
WITH wind[n] DO
BEGIN
if (UCharNo >= Lwide)
THEN UCharNo := UCharNo - Lwide
ELSE UCharNo := 1;
update_window(handle);
END;
END;
PROCEDURE Page_right;
BEGIN
WITH wind[n] DO
BEGIN
if (wind[n].UCharNo <= (Uwide - Lwide - 2))
THEN UCharNo := UCharNo + LWide
ELSE UcharNo := Uwide - Lwide - 2;
update_window(handle);
END;
END;
PROCEDURE Column_left;
BEGIN
if (wind[n].UCharNo > 0 ) THEN
BEGIN
wind[n].UCharNo := wind[n].UCharNo - 1;
update_window(wind[n].handle);
END;
END;
PROCEDURE Column_right;
BEGIN
WITH wind[n] DO
BEGIN
if (UCharNo <= (Uwide - Lwide)) THEN
BEGIN
UCharNo := UCharNo + 1;
update_window(handle);
END;
END;
END;
PROCEDURE No_move;
BEGIN
END;
BEGIN
n := Match_window(message[3]);
CASE message[4] OF
0: Page_up;
1: Page_down;
2: Row_up;
3: Row_down;
4: Page_left;
5: Page_right;
6: Column_left;
7: Column_right;
OTHERWISE: No_move;
END;
END;
FUNCTION NofK(X,Y:integer) : integer;
VAR
temp1, temp2 : real;
BEGIN
temp1 := X;
temp1 := temp1 / 1000.0;
temp2 := Y;
NofK := trunc(temp1*temp2) - 1;
END;
PROCEDURE Do_Hor; { Horizontal slider movement }
VAR
n : integer;
BEGIN
n := Match_Window(message[3]);
WITH wind[n] DO
BEGIN
UCharno := NofK(message[4],Uwide);
update_window(handle);
END;
END;
PROCEDURE Do_Ver; { Vertical slider movement }
VAR
n : integer;
newline : integer;
BEGIN
n := Match_Window(message[3]);
WITH wind[n] DO
BEGIN
newline := NofK(message[4],Uhigh);
IF (newline < Ulineno)
THEN prev_window(wind[n],Ulineno-newline)
ELSE
IF (newline > Ulineno)
THEN next_window(wind[n],newline-Ulineno);
END;
END;
PROCEDURE Do_Size;
{ Change the size of the current window, and remember the new size }
VAR
n : integer;
BEGIN
n := Match_Window(message[3]);
WITH wind[n] DO
BEGIN
Set_Wsize(handle,message[4],message[5],message[6],message[7]);
smallx := message[4];
smally := message[5];
smallw := message[6];
smallh := message[7];
windx := smallx;
windy := smally;
windw := smallw;
windh := smallh;
Update_Slides(wind[n]);
END;
END;
PROCEDURE Do_Move;
{ Move the current window to a new place }
VAR
n : integer;
BEGIN
n := Match_Window(message[3]);
WITH wind[n] DO
BEGIN
Set_Wsize(handle,message[4],message[5],message[6],message[7]);
smallx := message[4];
smally := message[5];
smallw := message[6];
smallh := message[7];
windx := smallx;
windy := smally;
windw := smallw;
windh := smallh;
Update_Slides(wind[n]);
END;
END;
PROCEDURE Do_Nothing;
BEGIN
END;
BEGIN
CASE message[0] of
MN_Selected : Do_Selection;
WM_Redraw : Do_Redraw;
WM_Topped : Do_Newtop;
WM_Closed : Do_Close;
WM_Fulled : Do_Fulled;
WM_Arrowed : Do_Arrowed;
WM_HSlid : Do_Hor;
WM_Vslid : Do_Ver;
WM_Sized : Do_Size;
WM_Moved : Do_move;
Otherwise : Do_Nothing;
END;
END;
PROCEDURE Do_Keyboard;
VAR
temp : integer;
BEGIN
IF key = $06200 THEN { HELP Key pushed }
temp := Do_Alert('[1][ I can''t fix your problems ][ Continue ]',1);
IF key = $06100 THEN { UNDO Key pushed }
BEGIN
temp :=
Do_Alert('[3][ Do you really want to Quit? ][ Quit | Continue ]',2);
running := (temp <> 1); { Return FALSE to Quit! }
END;
END;
PROCEDURE New_Mouse(f:Boolean; n:Integer);
VAR
i : Integer;
BEGIN
IF f THEN i := 1 ELSE i := 0;
i := i + (n * 2);
CASE i OF
0: Set_Mouse(M_Point_Hand);
1: Set_Mouse(M_Outln_Cross);
2: Set_Mouse(M_Arrow);
3: Set_Mouse(M_Thin_Cross);
OtherWise: Set_Mouse(M_Bee);
END;
END;
PROCEDURE Do_Button;
{ Mostly for form, change the cursor when the left Button changes }
BEGIN
B_Left := 1 - B_Left;
New_Mouse(InWindow,B_Left);
END;
PROCEDURE Do_Rect1;
{ Mostly for form, use the cursor shape to track if the mouse is in
or out of the active window }
BEGIN
InWindow := Not InWindow;
New_Mouse(InWindow,B_Left);
END;
PROCEDURE Do_Timer;
{ This one's just here to fill out the template }
VAR
i : integer;
r : real;
message : String;
rval : String;
BEGIN
r := (Get_Timer - Ticks) / 1000.0; { Convert to seconds elapsed }
Str(r,rval);
message := Concat('[1][ Program run | ', rval,
' | seconds ][ Continue ]');
i := Do_Alert(message,1);
END;
BEGIN { Wait for a GEM message or a keyboard event }
Work_Rect(Front_Window,Cur_X,Cur_Y,Cur_W,Cur_H);
i := Get_Event(E_Keyboard|E_Message|E_Button|E_Mrect_1|E_Timer,
1, B_Left, 1, { Wait for left button Change }
Delay, { Wait for timeout }
InWindow,Cur_X,Cur_Y,Cur_W,Cur_H, { Front Window border }
False,0,0,0,0, { No Rectangle 2 }
message, { Returns message if E_Message }
key, { Returns key pressed if E_Keyboard }
bcnt, { Returns button count if E_Button }
bstate, { Returns button status if E_Button }
mx, my, { Mouse position if E_Button }
kbd_state); { Keyboard state if E_Keyboard }
IF (i & E_Message) <> 0 THEN Do_Message;
IF (i & E_Keyboard) <> 0 THEN Do_Keyboard;
IF (i & E_Timer) <> 0 THEN Do_Timer;
IF (i & E_MRect_1) <> 0 THEN Do_Rect1;
IF (i & E_Button) <> 0 THEN Do_Button;
END; { Procedure Process }
PROCEDURE Clean_up;
VAR
i : integer;
BEGIN
FOR I := 1 to Max_wind DO
IF wind[i].InUse THEN
BEGIN
Close_Window(wind[i].handle);
Delete_Window(wind[i].handle);
END;
IF mouse_init THEN Set_Mouse(M_Arrow);
IF menu_init THEN
BEGIN
Erase_Menu(mymenu);
Delete_Menu(mymenu);
END;
Exit_Gem;
END;
PROCEDURE Go_For_It; { This is where it happens, Jack }
BEGIN
running := false;
Start_up;
While running do Process;
Clean_up;
END;
BEGIN { template }
IF Init_Gem >= 0 THEN Go_For_It;
END. { PROGRAM template }