[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]