Category : Pascal Source Code
Archive   : TMWIND.ZIP
Filename : TMWINDOW.PAS

 
Output of file : TMWINDOW.PAS contained in archive : TMWIND.ZIP
{--------------------------------------------------------------------------}
{Window applications of Object professional.

Last updated 18-SEP-90

(C) Tim Mackinnon
Cad Graphic Design Ltd.
206 Guigues Ave.
Ottawa On.
K1N 5J2

613 233-7246

Compuserve [72230,3101]

}

Unit tmWindow;

interface

uses
opRoot,
opCrt,
opCmd,
opWindow;

{--------------------------------------------------------------------------}
{A simple window to pop up without any fuss. }

const
tmUseShadows : boolean = true; {change to false to disallow shadows}

tmDefWindowOptions : longint = wClear+wSaveContents+wResizeable+wStoreContents+wBordered;


procedure plainWindowStream(sPtr : idStreamPtr);

type
plainWindow = object(commandWindow)

cp : commandProcessor;

constructor initCustom(x1,y1,x2,y2 : byte; title : string;
var colors : colorSet; options : longint);

constructor init(x1,y1,x2,y2 : byte; title : string);
constructor load(var S : idStream); {load an existing instance from a stream}

destructor done; virtual;

procedure store(var S : idStream);

procedure initCp; virtual;
procedure processSelf; virtual;
procedure erase; virtual;
end;
{--------------------------------------------------------------------------}
{A text file device window, so that obj.window^ can be used in write..
statements. Auto wrapping will occur too.}

type
textPtr = ^text;

msgWindowPtr = ^msgWindow;
msgWindow = object(plainWindow)

win : text;
flexAttr : char;

constructor initCustom(x1,y1,x2,y2 : byte; title : string;
var colors : colorSet; options : longint);

constructor init(x1,y1,x2,y2 : byte; title : string);
destructor done; virtual;

procedure clear; virtual;

procedure write(s : string); virtual;
procedure writeln(s : string);

procedure flexAttributes(VAR fAttrs : flexAttrs); virtual;
procedure maintainAttribute(s1 : string; VAR s2 : string);

function window : textPtr;
function winP : textPtr;
end;
{--------------------------------------------------------------------------}
scrollingMsgWindowPtr = ^scrollingMsgWindow;
scrollingMsgWindow = object(msgWindow)

vs : virtScreen;
R,C : word;

constructor initCustom(x1,y1,x2,y2 : byte; wid,hgt : word; title : string;
var colors : colorSet; options : longint);

constructor init(x1,y1,x2,y2 : byte; wid,hgt : word; title : string);
destructor done; virtual;

function winWidth : byte;
function width : word;
function winHeight : byte;
function height : word;

procedure updateContents; virtual;
procedure clear; virtual;
procedure activate;
procedure deactivate;
procedure write(s : string); virtual;
procedure writeln(s : string); virtual;

procedure processCmd; virtual;
procedure processself; virtual;
end;
{--------------------------------------------------------------------------}
{A button object will wait until the command key is pressed. The
command key is specified in msg with the ^ character (ie. ^Ok) }

buttonPtr = ^button;
button = object(commandWindow)

btext : string[20]; {Note arbitrary size for button text}
bchar : char;
cp : commandProcessor;
x,y : byte;

constructor init(x1,y1 : integer; msg : string);
destructor done; virtual;

procedure updateContents; virtual;
procedure erase; virtual;
procedure processSelf; virtual;

function asText : string;

function whereX1 : integer;
function whereY1 : integer;

function whereX2 : integer;
function whereY2 : integer;
end;

{--------------------------------------------------------------------------}
{So that later objects can assign a window }

procedure assignWindow(var F: text; var parentWindow : msgWindow);


{--------------------------------------------------------------------------}
{--------------------------------------------------------------------------}
implementation
{--------------------------------------------------------------------------}
uses
Dos,
opColor,
opKey,
opFrame,
opString,
opMouse, {for mouse support}
tmString; {for trim functions}
{--------------------------------------------------------------------------}
Type
windowDevObject = Record
parent : msgWindowPtr; {object linked to}
filler : array[1..12] of byte; {pad out to 16 bytes}
end;

{$F+}
{.........................................................................}
{The important part that accepts a variable number or parameters and
writes them to the report object.

CAVEAT: as the text file buffer length is 128, if your string is 126 long
then the CRLF is split in two buffer calls. To fix this, add a
trailing space.
}

function windowOutput(VAR F: TextRec) : integer;
var
i : word;
s : string;
b : byte;
begin
if F.Mode = fmOutput then
with F,windowDevObject(UserData) do
begin
b := lo(BufPos); {get number of characters,(only fit in a string)}

if b <> 0 then {only bother if we have something}
{this also solves problem of writing to a hiddent window when done is called}
begin
move(BufPtr^,s[1],b); {put characters in string}
move(b,s[0],1); {put size in string}

parent^.write(s); {writeln just appends CRLF, and write handles that!}

BufPos := 0; {Buffer has been cleared}
end;
end;

windowOutput := 0; {Successfull output}
end;

{..........................................................................}
{There is nothing to flush, so allways successfull.}

function windowFlush(VAR F: TextRec) : integer;
begin
windowFlush := 0;
end;

{.........................................................................}
{There is nothing to close, and so is allways successfull. }

function windowClose(VAR F: TextRec) : integer;
begin
F.mode := fmClosed;

windowClose := 0;
end;

{.........................................................................}
{Open is called by the reset, rewrite, and append standard procedures.
This function prepares the device for input or output according to the
Mode value. Open is always called before any other device, for that
reason, it it initialized the InOut, Flush and Close vectors. }

function windowOpen(VAR F: TextRec) : integer;
begin
with F do
begin
if (Mode = fmInput) OR (Mode = fmInOut) then
begin
Mode := fmClosed; {file access denied, write only device}
end
else
begin
Mode := fmOutput;
InOutFunc := @windowOutput;
FlushFunc := @windowOutput; {output only device uses this}
end;

CloseFunc := @windowClose;
end;
windowOpen := 0; {Successfull}
end;


{.........................................................................}
{Initialize the window device variable}

procedure assignWindow(var F: text; var parentWindow : msgWindow);
begin
with textRec(F) do
begin
handle := $ffff;
mode := fmClosed;
BufSize := sizeOf(Buffer);
BufPtr := @Buffer;
BufPos := 0;
OpenFunc := @windowOpen;

windowDevObject(UserData).parent := @parentWindow;

Name[0] := #0;
end;
end;

{$F-}
{--------------------------------------------------------------------------}
const
{# group} {# group} {# group}
keyMax = 4 * 3 + 9 * 4 + 10 * 4;

keySet : array[1..keyMax] of byte = (


{length keys command keySequence}

{groups of 3}

2, $1b, ccQuit, {esc}
2, $0d, ccSelect, {enter}
2, $09, ccNextField, {tab}
2, $0A, ccDone, {ctrl enter}


{groups of 4}

3, $00, $0f, ccPrevField, {shift tab}
3, lo(left), hi(left), ccLeft, {left arrow}
3, lo(right), hi(right), ccRight, {right arrow}
3, lo(up), hi(up), ccUp, {up arrow}
3, lo(down), hi(down), ccDown, {down arrow}
3, lo(home), hi(home), ccHome, {home key}
3, lo(endKey), hi(endKey), ccEnd, {end key}
3, lo(ins), hi(ins), ccIns, {insert}
3, lo(del), hi(del), ccDel, {delete}

{10 extra of group4}

0, 0, 0, 0, {space for more}
0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 0);

{--------------------------------------------------------------------------}
constructor plainWindow.initCustom;
begin
self.initCp;

if not commandWindow.initCustom(x1,y1,x2,y2,colors,options,cp,0) then
fail;

if wOptionsAreOn(wBordered) then
begin
self.wFrame.addHeader(title,heTc);

if tmUseShadows AND (width < screenWidth-4) AND (height < screenHeight - 3) then
self.wFrame.addShadow(shBR,shSeeThru);

self.wOptionsOn(wAltFrame);
self.wFrame.setFrameAttr(whiteOnBlue,whiteOnBlack); {active window is a different color}

self.aFrame.addHeaderColor(title,heTc,defaultColorSet.promptColor,
defaultColorSet.promptMono); {alternate frame has header too}
end;


end;
{..........................................................................}
constructor plainWindow.init;
begin
if not plainWindow.initCustom(x1,y1,x2,y2,title,
defaultColorSet,
tmDefWindowOptions) then
fail;
end;
{..........................................................................}

destructor plainWindow.done;
begin
cp.done;
commandWindow.done;
end;

{..........................................................................}
{This virtual method intializes the command processor. Later objects might
over-ride this to add more keys}

procedure plainWindow.initCp;
begin
cp.init(@keySet,keyMax); {can't fail}

cp.addCommand(ccQuit,1,mouseRt,0);
cp.addCommand(ccMouseSel,1,mouseLft,0);
cp.cpOptionsOn(cpEnableMouse);
end;
{..........................................................................}
{A convenient way to register the plainWindow type. }

{$F+}

procedure plainWindowStream(sPtr : idStreamPtr);
begin
sPtr^.registerHier(commandWindowStream); {Register parent, just in case}
end;

{$F-}
{..........................................................................}
constructor plainWindow.load;
begin
self.initCp; {initialize the command processor}
s.registerPointer(1000,@cp); {set up linkage to command processor for loading a command window from stream}

commandWindow.load(s);
end;
{..........................................................................}
procedure plainWindow.store;
begin
s.registerPointer(1000,@cp); {register linkage to command processor so we can resolve on loading the command window}
commandWindow.store(s);
end;
{..........................................................................}
procedure plainWindow.processSelf;
begin
clearErrors;
self.Draw;

repeat
getNextCommand;
until getLastCommand IN [ccQuit,ccSelect,ccError,ccDone,ccMouseSel,
ccNextField,ccPrevField,ccUser0..ccUser53];
end;
{..........................................................................}
{If not active, stop erase from failing}


procedure plainWindow.erase;
begin
if not isActive then {it has already been erased}
exit;

if self.isCurrent then
commandWindow.erase
else
self.eraseHidden; {hide it even if hidden}
end;
{--------------------------------------------------------------------------}
constructor msgWindow.initCustom;
begin
if not plainWindow.initCustom(x1,y1,x2,y2,title,colors,options) then
fail;

{new(window);}
assignWindow(win,self);

flexAttr := #255;

rewrite(win); {Standard DOS rewrite to initialize text device}
end;
{..........................................................................}
constructor msgWindow.init;
begin
if not msgWindow.initCustom(x1,y1,x2,y2,title,
defaultColorSet,
tmDefWindowOptions)
then
fail;
end;
{..........................................................................}
destructor msgWindow.done;
begin
close(win); {Standard DOS close, to uninitialize text device}
{dispose(window);}
plainWindow.done;
end;
{..........................................................................}
procedure msgWindow.clear;
begin
plainWindow.clear;
flexAttr := #255; {reset attribute to maintain}
end;
{..........................................................................}
{Return a pointer to the window text file. This is here for historical
reasons. WinP is easier to type, and win is the text file device that
can be accessed directly}

function msgWindow.window;
begin
window := @win;
end;

{..........................................................................}
{Return a pointer to the window text file}

function msgWindow.winP;
begin
winP := @win;
end;
{..........................................................................}
{This should be overwritten if write and writeln should use different
colours}

procedure msgWindow.flexAttributes;
const
attrsCo : flexAttrs = (yellowOnBlue,whiteOnBlue,ltGrayOnBlue,ltRedOnBlue);
attrsMo : flexAttrs = (ltGrayOnBlack,whiteOnBlack,blueOnBlack,whiteOnBlack);
begin
if useColor then
fAttrs := attrsCo
else
fAttrs := attrsMo;
end;
{..........................................................................}
{when word wrapping, we have to maintain the colored attribute, in s2
the leftover string}

const
attrChars = [^A,^B,^C];

procedure msgWindow.maintainAttribute;
var
ch1,ch2 : char;
i : integer;
begin
if s2 = '' then
exit;

ch1 := #0; ch2 := #0; {make sure they are the same}
for i := 1 to length(s1) do
if s1[i] IN attrChars then
begin
ch2 := ch1;
ch1 := s1[i];
end;

if ch1 <> ch2 then
begin
s2 := ch1 + s2; {if we have not turned attribute off, we must maintain it}
flexAttr := ch1;
end
else
begin
flexAttr := #255; {otherwise do not use a flex attribute}
end;

end;
{..........................................................................}
procedure msgWindow.write;
var
x,y,w,h : integer;
i,j : integer;
s1,s2,s3 : string;
fAttrs : flexAttrs;
begin
if flexAttr <> #255 then {if not equal to default attribute then we must change}
s3 := flexAttr + s {if buffer splits a string we must maintain attribute}
else
s3 := s;

w := self.width;
h := self.height;

repeat
i := 1;
while not (s3[i] in [#13,#10]) and (i <= length(s3)) do {go up to a CR or LF}
inc(i);


if i = 1 then {if we start at CR or LF, then process it!}
begin
self.wWhereXY(x,y);
if s3[i] = #13 then
wGotoXY(1,y) {CR}
else
wGotoXY(x,y+1); {LF}

delete(s3,1,1);
end;

if i > length(s3) then {if we traverse the whole string, then no CR's or LF's}
begin
s1 := s3;
s3 := '';
end
else {otherwise, leave the CR or LF for then next iteration}
begin
s1 := copy(s3,1,i-1);
s3 := copy(s3,i,length(s3)-i+1);
end;

repeat

self.wWhereXY(x,y);

if y > h then {don't write outside of window at bottom!}
exit;

i := w - x + 1; {calculate how much space is left in width}

if flexLen(extractWord(1,s1,[' '])) > i then {if we can't even fit a word, then wrap}
begin
if x = 1 then {if we will never fit it, then hyphenate it!}
begin
s2 := copy(s1,1,i-1) + '-';
delete(s1,1,i-1);
end
else
s2 := ''; {otherwise drop down a line and try again!}
end
else
wordWrap(s1,s2,s1,i+(i-flexLen(copy(s1,1,i))),false);

self.maintainAttribute(s2,s1); {first parameter write string, second is left over}

self.flexAttributes(fAttrs); {get attributes to use, so we can over-ride if necessary}
self.wFlexWrite(s2,y,x,fAttrs);

if s1 <> '' then
self.wGotoXY(1,y+1)
else
if (x + flexLen(s2)) > w then {adjust down if write ended up flush on right margin}
self.wGotoXY(1,y+1)
else
self.wGotoXY(x + flexLen(s2),y);


until s1 = '';
until s3 = '';
end;
{..........................................................................}
procedure msgWindow.writeln;
var
x,y : integer;
begin
self.write(s);

{Write is supposed to take care of all CRLF's so no need for writeln anymore!}
{
self.wWhereXY(x,y);
self.wGotoXY(1,y+1);
}
end;
{--------------------------------------------------------------------------}
constructor scrollingMsgWindow.initCustom;
begin
if not msgWindow.initCustom(x1,y1,x2,y2,title,colors,options) then
fail;

if not vs.alloc(hgt,wid) then
fail;

R := 1; {top coordinates of the screen}
C := 1;

{add scroll bars. Notice maxUser parameter stops the vs from scrolling
beyond what the window can show}

wFrame.addScrollBar(frRR,1,hgt-(winHeight),defaultColorSet);
aFrame.addScrollBar(frRR,1,hgt-(winHeight),defaultColorSet);

wFrame.addScrollBar(frBB,1,wid-(winWidth),defaultColorSet);
aFrame.addScrollBar(frBB,1,wid-(winHeight),defaultColorSet);
end;
{..........................................................................}
constructor scrollingMsgWindow.init;
begin
if not scrollingMsgWindow.initCustom(x1,y1,x2,y2,wid,hgt,title,
defaultColorSet,tmDefWindowOptions)
then
fail;
end;
{..........................................................................}
destructor scrollingMsgWindow.done;
begin
vs.done;

msgWindow.done;
end;
{..........................................................................}
procedure scrollingMsgWindow.updateContents;
begin
vs.copyToWindow(R,C);

drawSlider(frRR,R);
drawSlider(frBB,C);
end;
{..........................................................................}
procedure scrollingMsgWindow.clear;
begin
with defaultColorSet do
vs.clear(colorMono(textColor,textMono),defBackChar);

R := 1;
C := 1;

updateContents;
end;
{..........................................................................}
function scrollingMsgWindow.width;
begin
width := vs.vCols;
end;
{..........................................................................}
function scrollingMsgWindow.winWidth;
begin
winWidth := msgWindow.width;
end;
{..........................................................................}
function scrollingMsgWindow.height;
begin
height := vs.vRows;
end;
{..........................................................................}
function scrollingMsgWindow.winHeight;
begin
winHeight := msgWindow.height;
end;
{..........................................................................}
procedure scrollingMsgWindow.activate;
begin
vs.activate;
end;
{..........................................................................}
procedure scrollingMsgWindow.deactivate;
begin
vs.deactivate;
end;
{..........................................................................}
{Allow writing like in a message window}

procedure scrollingMsgWindow.write;
begin
self.activate;
msgWindow.write(s);
self.deactivate;
end;
{..........................................................................}
procedure scrollingMsgWindow.writeln;
var
x,y : integer;
begin
self.activate;
msgWindow.write(s);

self.wWhereXY(x,y);
self.wGotoXY(1,y+1);
self.deactivate;
end;
{..........................................................................}
procedure scrollingMsgWindow.processCmd;
var
cmd : word;
userVal : word;

framePos : framePosType;
hotCode : byte;
begin
cmd := getLastCommand;

if cmd = ccMouseSel then
begin
self.evaluateMousePos;
userVal := self.posResults(framePos,hotCode);

case hotCode of
hsDecV : cmd := ccUp;
hsIncV : cmd := ccDown;
hsIncH : cmd := ccRight;
hsDecH : cmd := ccLeft;
hsBar :
case framePos of
frRR : begin
userVal := tweakSlider(frRR,mouseLastY+mouseYLo,userVal,1);
R := userVal;
end;
frBB : C := userVal;
end;
end;
end;

case cmd of

ccRight : if (C < (width - winWidth)) then
inc(c);
ccLeft : if (c > 1) then
dec(C);
ccUp : if (R > 1) then
dec(R);
ccDown : if (R < (height - winHeight)) then
inc(R);

ccMouseSel : {};
else
begin
exit;
end;
end;

updateContents;
end;
{..........................................................................}
procedure scrollingMsgWindow.processSelf;
begin
clearErrors;
self.Draw;

repeat
getNextCommand;

self.processCmd;

until getLastCommand IN [ccQuit,ccSelect,ccError,ccDone,
ccNextField,ccPrevField,ccUser0..ccUser53];
end;
{--------------------------------------------------------------------------}
constructor button.init;

const
buttonFrame : frameArray = 'ÚÔ·¼Äͳº';
var
i : integer;
w : integer;
begin
i := pos('^',msg); {find the control key}
if i = 0 then
begin
insert(^A,msg,1);
insert(^A,msg,3);
bchar := upcase(msg[2]);
end
else
begin
msg[i] := ^A;
insert(^A,msg,i+2);
bchar := upcase(msg[i+1]);
end;

cp.init(@keySet,keyMax); {can't fail}
cp.addCommand(ccQuit,1,mouseRt,0); {add mouse commands}
cp.addCommand(ccMouseSel,1,mouseLft,0);

cp.cpOptionsOn(cpEnableMouse);

if not commandWindow.initCustom(x1,y1,x1 + length(msg) -1,y1,
defaultColorSet,
tmDefWindowOptions and not(wClear + wSaveContents) or wUserContents,
cp,0)
then
fail;

x := x1; y := y1;


self.wOptionsOn(wAltFrame);
self.aFrame.setFrameType(buttonFrame);
self.wFrame.setFrameType(buttonFrame);
self.wFrame.setFrameAttr(whiteOnBlue,white);

btext := msg;
end;
{..........................................................................}
{We need to prevent double disposal of a button as it is used in a
command window and added as a child window}

destructor button.done;
begin
commandWindow.done;
end;
{..........................................................................}
{We need to over-ride erase, becuase the chances are that there are multiple

buttons that need to be erased, and erasing a non current button results
in a non-fatal error. If we use the eraseHidden method, this does not
happen.}

procedure button.erase;
begin
if not isActive then {it has already been erased}
exit;

if self.isCurrent then
commandWindow.erase
else
self.eraseHidden; {hide it even if hidden}
end;
{..........................................................................}
{This is virtually used by select,draw so we will need to over-ride this!}

procedure button.updateContents;
const
fattrs : flexAttrs = (ltGrayOnBlue,whiteOnBlue,ltredOnBlue,yellowOnBlue);
begin
clearErrors;
commandWindow.updateContents;
self.wFlexWrite(' ' + btext + ' ',1,1,fattrs);
end;
{..........................................................................}
procedure button.processSelf;
var
framePos : framePosType;
hotSPot : byte;
begin
clearErrors;
self.Draw;

repeat
getNextCommand; {as per example 4-139;}

if (getLastCommand = ccChar) then
if upcase(chr(lo(getLastKey))) = bchar then
setLastCommand(ccDone)
else
setLastCommand(ccUser0); {get out so we can test for another button}

until getLastCommand IN [ccQuit,ccSelect,ccError,ccDone,
ccLeft,ccRight,
ccNextField,ccPrevField,ccMouseSel,
ccUser0..ccUser53];


CASE getLastCommand OF

ccMouseSel:
begin
evaluateMousePos;
if posResults(framePos,hotSpot) = 0 then {}; {ignore result}

if framePos = frInsideActive then
setLastCommand(ccDone);
end;

ccSelect:
begin
setLastCommand(ccDone); {Pressing enter should exit button}
end;
end;
end;
{..........................................................................}
function button.whereX1;
begin
whereX1 := x - 1; {account for border}
end;
{..........................................................................}
function button.whereX2;
begin
whereX2 := self.whereX1 + self.width + 2; {account for border}
end;
{..........................................................................}
function button.whereY1;
begin
whereY1 := y - 1; {account for border}
end;
{..........................................................................}
function button.whereY2;
begin
whereY2 := self.whereY1 + self.height + 2; {account for border}
end;
{..........................................................................}
{Return the text associated with a button}

function button.asText;
begin
asText := trimAllWhite(btext);
end;

{--------------------------------------------------------------------------}
end.

  3 Responses to “Category : Pascal Source Code
Archive   : TMWIND.ZIP
Filename : TMWINDOW.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/