[Back to OOP SWAG index] [Back to Main SWAG index] [Original]
unit grafwin;
{****************************************************************************}
{** **}
{** GRAFWIN **}
{** **}
{** Grafics in Turbo-Vision's Textmode **}
{** **}
{** This program and source are PUBLIC DOMAIN **}
{** **}
{****************************************************************************}
{** **}
{** by Stefan Michel (2:2490/1145.6) **}
{** **}
{** Fontmanipulations by David Dahl (1:272/38.0) **}
{** **}
{****************************************************************************}
{** **}
{** This example uses a second font as a pseudo-graphics window. **}
{** This program requires VGA. **}
{** **}
{****************************************************************************}
interface
uses objects,views;
{Palette for TGraf}
const
CGraf = #8#6;
type
pgraf=^tgraf;
tgraf=object(tview)
{A View graphic-view-object}
constructor Init(Var Bounds: TRect);
destructor Done; virtual;
procedure ChangeBounds(var Bounds: TRect); virtual;
procedure SetState(AState: Word; Enable: Boolean); virtual;
function GetPalette: PPalette; virtual;
procedure Draw; virtual;
procedure Update(Const isdraw:boolean); virtual;
{Draws the graphic, use PutPixel, etc. here!}
procedure Clear;
{Clear the graphic}
procedure PutPixel (Xin, Yin : Word; FG:Boolean);
{Puts a Pixel. if FG then color is the Foregroundcolor}
procedure PutLine (XStart, YStart, XEnd, YEnd : Word; FG:Boolean);
procedure PutCircle (XCoord, YCoord, Radius : Integer; FG:Boolean);
procedure PutRectangle (X1, Y1, X2, Y2 : Word; FG:Boolean);
end;
pclock=^tclock;
tclock=object(tgraf)
{shows a analog clock in a TV-Window}
Hours,Mins,Secs:Word;
Constructor Init(var Bounds:TRect);
procedure update(const isdraw:boolean); virtual;
end;
pgrafwin=^tgrafwin;
tgrafwin=object(twindow)
{A window, that changes the boarder of tgraf correctly}
graf:pgraf;
constructor Init(var Bounds: TRect; ATitle: TTitleStr; ANumber:Integer);
procedure ChangeBounds(var Bounds: TRect); virtual;
procedure insertgraf(agraf:pgraf);
end;
const
grcount:word=0; {Counter how many graf-objects are initialized}
implementation
uses dos,drivers,app;
Procedure SetCharWidthTo8; Assembler;
{by David Dahl}
Asm
{ Change To 640 Horz Res }
MOV DX, $3CC
IN AL, DX
AND AL, Not(4 OR 8)
MOV DX, $3C2
OUT DX, AL
{ Turn Off Sequence Controller }
MOV DX, $3C4
MOV AL, 0
OUT DX, AL
MOV DX, $3C5
MOV AL, 0
OUT DX, AL
{ Reset Sequence Controller }
MOV DX, $3C4
MOV AL, 0
OUT DX, AL
MOV DX, $3C5
MOV AL, 3
OUT DX, AL
{ Switch To 8 Pixel Wide Fonts }
MOV DX, $3C4
MOV AL, 1
OUT DX, AL
MOV DX, $3C5
IN AL, DX
OR AL, 1
OUT DX, AL
{ Turn Off Sequence Controller }
MOV DX, $3C4
MOV AL, 0
OUT DX, AL
MOV DX, $3C5
MOV AL, 0
OUT DX, AL
{ Reset Sequence Controller }
MOV DX, $3C4
MOV AL, 0
OUT DX, AL
MOV DX, $3C5
MOV AL, 3
OUT DX, AL
{ Center Screen }
MOV DX, $3DA
IN AL, DX
MOV DX, $3C0
MOV AL, $13 OR 32
OUT DX, AL
MOV AL, 0
OUT DX, AL
End;
{-[ Turn On Dual Fonts ]--------------------------------------------------}
Procedure SetDualFonts; Assembler;
{by David Dahl}
ASM
{ Set Fonts 0 & 1 }
MOV BL, 4
MOV AX, $1103
INT $10
END;
{-[ Turn On Access To Font Memory ]---------------------------------------}
Procedure SetAccessToFontMemory; Assembler;
{by David Dahl}
ASM
{ Turn Off Sequence Controller }
MOV DX, $3C4
MOV AL, 0
OUT DX, AL
MOV DX, $3C5
MOV AL, 1
OUT DX, AL
{ Reset Sequence Controller }
MOV DX, $3C4
MOV AL, 0
OUT DX, AL
MOV DX, $3C5
MOV AL, 3
OUT DX, AL
{ Change From Odd/Even Addressing to Linear }
MOV DX, $3C4
MOV AL, 4
OUT DX, AL
MOV DX, $3C5
MOV AL, 7
OUT DX, AL
{ Switch Write Access To Plane 2 }
MOV DX, $3C4
MOV AL, 2
OUT DX, AL
MOV DX, $3C5
MOV AL, 4
OUT DX, AL
{ Set Read Map Reg To Plane 2 }
MOV DX, $3CE
MOV AL, 4
OUT DX, AL
MOV DX, $3CF
MOV AL, 2
OUT DX, AL
{ Set Graphics Mode Reg }
MOV DX, $3CE
MOV AL, 5
OUT DX, AL
MOV DX, $3CF
MOV AL, 0
OUT DX, AL
{ Set Misc. Reg }
MOV DX, $3CE
MOV AL, 6
OUT DX, AL
MOV DX, $3CF
MOV AL, 12
OUT DX, AL
End;
{-[ Turn On Access to Text Memory ]---------------------------------------}
Procedure SetAccessToTextMemory; Assembler;
{by David Dahl}
ASM
{ Turn Off Sequence Controller }
MOV DX, $3C4
MOV AL, 0
OUT DX, AL
MOV DX, $3C5
MOV AL, 1
OUT DX, AL
{ Reset Sequence Controller }
MOV DX, $3C4
MOV AL, 0
OUT DX, AL
MOV DX, $3C5
MOV AL, 3
OUT DX, AL
{ Change To Odd/Even Addressing }
MOV DX, $3C4
MOV AL, 4
OUT DX, AL
MOV DX, $3C5
MOV AL, 3
OUT DX, AL
{ Switch Write Access }
MOV DX, $3C4
MOV AL, 2
OUT DX, AL
MOV DX, $3C5
MOV AL, 3 {?}
OUT DX, AL
{ Set Read Map Reg }
MOV DX, $3CE
MOV AL, 4
OUT DX, AL
MOV DX, $3CF
MOV AL, 0
OUT DX, AL
{ Set Graphics Mode Reg }
MOV DX, $3CE
MOV AL, 5
OUT DX, AL
MOV DX, $3CF
MOV AL, $10
OUT DX, AL
{ Set Misc. Reg }
MOV DX, $3CE
MOV AL, 6
OUT DX, AL
MOV DX, $3CF
MOV AL, 14
OUT DX, AL
End;
constructor tgraf.Init(var Bounds: TRect);
var t:byte;p:^byte;
begin
{a new graf-object}
inc(grcount);
{redefining vga palette 4->B,5->E,6->F}
asm
mov ax,1000h
mov bl,4
mov bh,3Bh
int 10h
mov ax,1000h
mov bl,5
mov bh,3Eh
int 10h
mov ax,1000h
mov bl,6
mov bh,3Fh
int 10h
end;
{delete bit3 of all palette-entries}
with Application^ do
for t:=1 to byte(getpalette^[0]) do
begin
p:=@GetPalette^[t];
case p^ and $F of
$B:p^:=p^ and $F0 or $4;
$A,$E:p^:=p^ and $F0 or $5;
$F:p^:=p^ and $F0 or $6;
else p^:=p^ and $f7;
end;
end;
{suppress shadow-errors with the graphic-view}
shadowattr:=0;
{color of graphics; use reserved palette-entry}
application^.getpalette^[15]:=#$1F;
{calc bounds}
if (bounds.b.y-bounds.a.y)*(bounds.b.x-bounds.a.x)>255 then
bounds.b.y:=bounds.a.y+256 div (bounds.b.x-bounds.a.x);
inherited init(bounds);
{setup video}
SetCharWidthTo8;
SetDualFonts;
clear;
end;
destructor tgraf.done;
begin
inherited done;
{delete a graf-object}
dec(grcount);
end;
procedure tgraf.SetState(AState: Word; Enable: Boolean);
var s:word;
begin
{redraw, if an other is selected}
s:=state and (sfactive or sfdragging);
inherited setstate(astate,enable);
if s <>(state and (sfactive or sfdragging)) then
draw;
end;
procedure tgraf.draw;
var
b:tdrawbuffer;
x,y,t,col:byte; c:char;
begin
hidemouse;
col:=getcolor(1);
{draw only if active and not dragging}
if (not getstate(sfdragging)) and (getstate(sfactive) or (grcount<2)) then
begin
clear;
for y:=0 to size.y-1 do
begin
for x:= 0 to size.x-1 do
B[x]:=(x+y*size.x) or col shl 8;
WriteLine(0, y, Size.X, 1, B);
end;
update(true);
end
else
{draw nothing}
begin
movechar(b[0],#32,getcolor(2),size.x);
WriteLine(0, 0, Size.X, size.y, B);
end;
showmouse;
end;
procedure tgraf.ChangeBounds(var Bounds: TRect);
var
t:tpoint;
begin
{redraw if size changed}
t:=size;
if (bounds.b.y-bounds.a.y)*(bounds.b.x-bounds.a.x)>255 then
bounds.b.y:=bounds.a.y+256 div (bounds.b.x-bounds.a.x);
inherited changeBounds(Bounds);
if (T.x<>size.x) or (t.y<>size.y) then
draw;
end;
function tgraf.GetPalette: PPalette;
const
P: String[Length(Cgraf)] = Cgraf;
begin
GetPalette := @P;
end;
procedure tgraf.update(const isdraw:boolean);
{dummy}
begin
end;
{-[ Clear The Pseudo-Graphics Window by Clearing Font Definition ]--------}
Procedure tgraf.Clear;
{by David Dahl}
Begin
SetAccessToFontMemory;
FillChar (MEM[$B800:$4000], 32 * 256, 0);
SetAccessToTextMemory;
End;
{-[ Plot a Pixel in The Pseudo-Graphics Window ]--------------------------}
Procedure tgraf.PutPixel (Xin, Yin : Word; FG:Boolean);
{partially by David Dahl}
Var RealY,
RealX : Word;
Begin
If (Xin > 0 ) AND (Yin > 0 ) AND
(Xin < size.x*8) AND
(Yin < size.y*16)
Then
Begin
RealX := (Xin DIV 8) * 32;
RealY := (Yin MOD 16) + ((Yin DIV 16) * (32 * size.x));
SetAccessToFontMemory;
if FG then
MEM[$B800:$4000 + RealX + RealY] :=
MEM[$B800:$4000 + RealX + RealY] OR (128 SHR (Xin MOD 8))
else
MEM[$B800:$4000 + RealX + RealY] :=
MEM[$B800:$4000 + RealX + RealY] AND NOT (128 SHR (Xin MOD 8));
SetAccessToTextMemory;
End;
End;
{-[ Draw A Line ]---------------------------------------------------------}
{ OCTANT DDA Subroutine converted from the BASIC listing on pages 26 - 27 }
{ from the book _Microcomputer_Displays,_Graphics,_ And_Animation_ by }
{ Bruce A. Artwick }
Procedure tgraf.PutLine (XStart, YStart, XEnd, YEnd : Word; FG:Boolean);
{by David Dahl}
Var StartX,
StartY,
EndX,
EndY : Word;
DX,
DY : Integer;
CNTDWN : Integer;
Errr : Integer;
Temp : Integer;
NotDone : Boolean;
Begin
NotDone := True;
StartX := XStart;
StartY := YStart;
EndX := XEnd;
EndY := YEnd;
If EndX < StartX Then
Begin
{ Mirror Quadrants 2,3 to 1,4 }
Temp := StartX;
StartX := EndX;
EndX := Temp;
Temp := StartY;
StartY := EndY;
EndY := Temp;
End;
DX := EndX - StartX;
DY := EndY - StartY;
If DY < 0 Then
Begin
If -DY > DX Then
Begin
{ Octant 7 Line Generation }
CntDwn := -DY + 1;
ERRR := -(-DY shr 1); {Fast Divide By 2}
While NotDone do
Begin
PutPixel (StartX, StartY,FG);
Dec (CntDwn);
If CntDwn <= 0
Then NotDone := False
Else
Begin
Dec(StartY);
Inc(Errr, DX);
If Errr >= 0 Then
Begin
Inc(StartX);
Inc(Errr, DY);
End;
End;
End;
End
Else
Begin
{ Octant 8 Line Generation }
CntDwn := DX + 1;
ERRR := -(DX shr 1); {Fast Divide By 2}
While NotDone do
Begin
PutPixel (StartX, StartY, FG);
Dec (CntDwn);
If CntDwn <= 0
Then NotDone := False
Else
Begin
Inc(StartX);
Dec(Errr, DY);
If Errr >= 0 Then
Begin
Dec(StartY);
Dec(Errr, DX);
End;
End;
End;
End;
End
Else If DY > DX Then
Begin
{ Octant 2 Line Generation }
CntDwn := DY + 1;
ERRR := -(DY shr 1); {Fast Divide By 2}
While NotDone do
Begin
PutPixel (StartX, StartY, FG);
Dec (CntDwn);
If CntDwn <= 0
Then NotDone := False
Else
Begin
Inc(StartY);
Inc(Errr, DX);
If Errr >= 0 Then
Begin
Inc(StartX);
Dec(Errr, DY);
End;
End;
End;
End
Else
{ Octant 1 Line Generation }
Begin
CntDwn := DX + 1;
ERRR := -(DX shr 1); {Fast Divide By 2}
While NotDone do
Begin
PutPixel (StartX, StartY, FG);
Dec (CntDwn);
If CntDwn <= 0
Then NotDone := False
Else
Begin
Inc(StartX);
Inc(Errr, DY);
If Errr >= 0 Then
Begin
Inc(StartY);
Dec(Errr, DX);
End;
End;
End;
End;
End;
{-[ Draw A Circle ]-----------------------------------------------------}
{ Algorithm based on the Pseudocode from page 83 of the book _Advanced }
{ Graphics_In_C_ by Nelson Johnson }
Procedure tgraf.PutCircle (XCoord, YCoord, Radius : Integer; FG : Boolean);
{by David Dahl}
Var d : Integer;
X, Y : Integer;
Procedure Symmetry (xc, yc, x, y : integer);
Begin
PutPixel ( X+xc, Y+yc, FG);
PutPixel ( X+xc, -Y+yc, FG);
PutPixel (-X+xc, -Y+yc, FG);
PutPixel (-X+xc, Y+yc, FG);
PutPixel ( Y+xc, X+yc, FG);
PutPixel ( Y+xc, -X+yc, FG);
PutPixel (-Y+xc, -X+yc, FG);
PutPixel (-Y+xc, X+yc, FG);
End;
Begin
x := 0;
y := abs(Radius);
d := 3 - 2 * y;
While (x < y) do
Begin
Symmetry (XCoord, YCoord, x, y);
if (d < 0) Then
inc(d, (4 * x) + 6)
else
Begin
inc (d, 4 * (x - y) + 10);
dec (y);
End;
inc(x);
End;
If x = y then
Symmetry (XCoord, YCoord, x, y);
End;
{-[ Draw A Rectangle ]----------------------------------------------------}
Procedure tgraf.PutRectangle (X1, Y1, X2, Y2 : Word; FG : Boolean);
{by David Dahl}
Begin
{ Draw Top Of Box }
PutLine (X1, Y1, X2, Y1, FG);
{ Draw Right Side Of Box }
PutLine (X2, Y1, X2, Y2, FG);
{ Draw Left Side Of Box }
PutLine (X1, Y1, X1, Y2, FG);
{ Draw Botton Of Box }
PutLine (X1, Y2, X2, Y2, FG);
End;
Constructor TClock.Init(var Bounds:TRect);
var S,HS:Word;
begin
inherited Init(Bounds);
GetTime(Hours,Mins,S,HS);
end;
procedure TClock.update;
var H,M,S,HS:Word;
X1,Y1,X2,Y2,Xm,Ym,
Xd,Yd,xd2,yd2,DX,DY,R:Integer;
sec,si,co:real;
procedure PtrLine(Part,DX,DY:Integer;
var Xd,Yd:Integer);
begin
sec:=(pi*2/60)*part;
xd:=round(xm+sin(sec)*(xm-dx));
yd:=round(ym-cos(sec)*(ym-dy));
end;
begin
X1:=2;
X2:=Size.X*8-2;
Y1:=2;
Y2:=Size.Y*16-2;
Xm:=(X1+X2)DIV 2;
Ym:=(Y1+Y2)DIV 2;
DX:=(X2-X1)DIV 32;
DY:=(Y2-Y1)DIV 32;
if isdraw then
begin
{the face}
hidemouse;
for R:=0 to 59 do
begin
sec:=(pi*2/60)*r;
si:=sin(sec); co:=cos(sec);
if r mod 5 =0 then
begin
xd:=round(xm+si*(xm-2*dx));
yd:=round(ym-co*(ym-2*dy));
end
else
begin
xd:=round(xm+si*(xm-dx));
yd:=round(ym-co*(ym-dy));
end;
xd2:=round(xm+si*x2/2);
yd2:=round(ym-co*y2/2);
putline(xd,yd,xd2,yd2,True);
end;
showmouse;
end;
GetTime(H,M,S,HS);
if(S<>Secs)OR(M<>Mins)
OR(H<>Hours)then
begin
{the hand}
hidemouse;
DX:=(X2-X1)DIV 16;
DY:=(Y2-Y1)DIV 16;
PtrLine(Secs,DX,DY,Xd,Yd);
PutLine(Xm,Ym,Xd,Yd,False);
PtrLine(S,DX,DY,Xd,Yd);
PutLine(Xm,Ym,Xd,Yd,True);
DX:=(X2-X1)DIV 8;
DY:=(Y2-Y1)DIV 8;
PtrLine(Mins,DX,DY,Xd,Yd);
PutLine(Xm,Ym,Xd,Yd,False);
PtrLine(M,DX,DY,Xd,Yd);
PutLine(Xm,Ym,Xd,Yd,True);
DX:=(X2-X1)DIV 4;
DY:=(Y2-Y1)DIV 4;
PtrLine(Hours MOD 12*5,DX,DY,Xd,Yd);
PutLine(Xm,Ym,Xd,Yd,False);
PtrLine(H MOD 12*5,DX,DY,Xd,Yd);
PutLine(Xm,Ym,Xd,Yd,True);
showmouse;
Hours:=H;
Mins:=M;
Secs:=S;
end;
end;
constructor tgrafwin.Init(var Bounds: TRect; ATitle: TTitleStr;
ANumber:Integer); begin inherited init(bounds,atitle,anumber);
getextent(bounds); {graf^.growmode:=gfgrowhix or gfgrowhiy;} end;
procedure tgrafwin.insertgraf(agraf:pgraf);
var bounds:trect;
begin
graf:=agraf;
getextent(bounds);
bounds.grow(-1,-1);
graf^.changebounds(bounds);
insert(graf);
end;
procedure tgrafwin.ChangeBounds(var Bounds: TRect);
var t:trect;
begin
inherited changeBounds(Bounds);
getextent(t);
t.grow(-1,-1);
if graf<>nil then
graf^.changeBounds(t);
redraw;
end;
end.
program grafwi_d;
{****************************************************************************}
{** **}
{** GRAFWIN (DEMO) **}
{** **}
{** Grafics in Turbo-Vision's Textmode **}
{** **}
{** This program and source are PUBLIC DOMAIN **}
{** **}
{****************************************************************************}
{** **}
{** by Stefan Michel (2:2490/1145.6) **}
{** **}
{** Fontmanipulations by David Dahl (1:272/38.0) **}
{** **}
{****************************************************************************}
{** **}
{** This example uses a second font as a pseudo-graphics window. **}
{** This program requires VGA. **}
{** **}
{****************************************************************************}
uses dos,objects,drivers,views,app,grafwin,msgbox;
type
tmyapp=object(tapplication)
grafclock:pclock;
constructor init;
procedure idle; virtual;
end;
constructor tmyapp.init;
var
g:pgrafwin;
r:trect;
begin
inherited init;
r.assign(58,1,78,10);
new(g,init(r,'Clock',0));
grafclock:=new(pclock,init(r));
g^.insertgraf(grafclock);
desktop^.insert(g);
showmouse;
messagebox(^c'Yes, this is textmode!',nil,mfinformation+mfokbutton);
messagebox(^c'GRAFWIN (c) 1994 by'^m^c'Stefan Michel'^m^c'Irisstraáe 12'+
^m^c'D-90542 Brand',nil,mfinformation+mfokbutton);
end;
procedure tmyapp.idle;
begin
inherited idle;
grafclock^.update(false);
end;
var
a:tmyapp;
begin
setvideomode(smco80);
a.init;
a.run;
a.done;
setvideomode(smco80);
end.
[Back to OOP SWAG index] [Back to Main SWAG index] [Original]