[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]

    {
    I hope you can do something With these listings
    I downloaded from a BBS near me....
    This File contains:  Program VGA3d
                         Unit DDFigs
                         Unit DDVars
                         Unit DDVideo
                         Unit DDProcs
    Just break it in pieces on the cut here signs......

    if you need some Units or Programs (or TxtFiles) on Programming the Adlib/
    Sound-Blaster or Roland MPU-401, just let me know, and i see if i can dig
    up some good listings.....
    But , will your game also have Soundblaster/adlib fm support and Sound
    Blaster Digitized Sound support, maybe even MPU/MT32? support....
    And try to make it as bloody as you can (Heads exploding etc..)(JOKE)

    I hope i you can complete your game (i haven't completed any of my games yet)
    And i like a copy of it when it's ready......

    Please leave a message if you received this File.

      Andre Jakobs
        MicroBrain Technologies Inc.
            GelderlandLaan 9
              5691 KL   Son en Breugel
                The Netherlands............
    }

    Program animatie_van_3d_vector_grafics;

    Uses
      Crt,
      ddvideo,
      ddfigs,
      ddprocs,
      ddVars;

    Var
      Opal : paletteType;

    Procedure wireframe(pro : vertex2Array);
    { Teken een lijnen diagram van gesloten voorwerpen met vlakken }
    Var
      i, j, k,
      v1, v2  : Integer;
    begin
      For i :=  1 to ntf DO
      begin
        j := nfac[i];
        if j <> 0 then
        begin
          v1 := faclist[ facfront[j] + size[j] ];
          For k :=  1 to size[j] DO
          begin
            v2 := faclist[facfront[j] + k];
            if (v1<v2) or (super[i] <> 0 ) then
              linepto(colour[j], pro[v1], pro[v2])
            v1 := v2;
          end;
        end;
      end;
    end;

    Procedure hidden(pro : vertex2Array);
    { Display van Objecten als geheel van de projectiepunten van pro }
    { b is een masker voor de kleuren }
    Var
      i,  col : Integer;

      Function signe( n : Real) : Integer;
      begin
        if n >0 then
          signe := -1
        else
        if n <0 then
          signe := 1
        else
          signe := 0;
      end;

      Function orient(f : Integer; v : vertex2Array) : Integer;
      Var
        i, ind1,
        ind2, ind3 : Integer;
        dv1, dv2   : vector2;
      begin
        i := nfac[f];
        if i = 0 then
          orient := 0
        else
        begin
          ind1   := faclist[facfront[i] + 1];
          ind2   := faclist[facfront[i] + 2];
          ind3   := faclist[facfront[i] + 3];
          dv1.x  := v[ind2].x - v[ind1].x;
          dv1.y  := v[ind2].y - v[ind1].y;
          dv2.x  := v[ind3].x - v[ind2].x;
          dv2.y  := v[ind3].y - v[ind2].y;
          orient := signe(dv1.x * dv2.y - dv2.x * dv1.y);
        end;
      end;

      Procedure facetfill(k : Integer);
      Var
        v           : vector2Array;
        i, index, j : Integer;
      begin
        j := nfac[k];
        For i :=  1 to size[j] DO
        begin
          index := faclist[facfront[j] + i];
          v[i]  := pro[index];
        end;
        fillpoly(colour[k], size[j], v);
        polydraw(colour[k] - 1, size[j], v);
      end;

      Procedure seefacet(k : Integer);
      Var
        ipt, supk : Integer;
      begin
        facetfill(k);
        ipt := firstsup[k];
        While ipt <> 0 DO
        begin
          supk := facetinfacet[ipt].info;
           facetfill(supk);
          ipt := facetinfacet[ipt].Pointer;
        end;
      end;

    { hidden Programmacode }
    begin
      For i := 1 to nof DO
      if super[i] = 0 then
        if orient(i, pro) = 1 then
          seefacet(i);
    end;

    Procedure display;
    Var
      i : Integer;
    begin
      {observe}
      For i := 1 to nov DO
        transform(act[i], Q, obs[i]);

      {project}
      ntv := nov;
      ntf := nof;
      For i := 1 to ntv DO
      begin
        pro[i].x := obs[i].x;
        pro[i].y := obs[i].y;
      end;

      {drawit}
      switch := switch xor 1;
      hidden(pro);
      Scherm_actief(switch);
      Virscherm_actief(switch xor 1);
      wisscherm(prevpoints, $a000, $8a00);
      wis_hline(prevhline, $8a00);
      prevpoints := points;prevhline := hline;
      points[0]  := 0;
      hline[0]   := 0;
    end;

    Procedure anim3d;
    Var
      A, B, C, D, E, F,
      G, H, I, J, QE, P    : matrix4x4;
      zoom, inz, inzplus   : Real;
      angle, angleinc,
      beta, betainc, frame : Integer;
      huidigpalette        : paletteType;

      { Kubus Animatie : Roterende kubus }
      Procedure kubus;
      begin
        angle    := 0;
        angleinc := 9;
        beta     := 0;
        betainc  := 2;
        direct.x := 9;
        direct.y := 2;
        direct.z := -3;
        findQ;
        cubesetup(104);
        frame := 0;

        While (NOT (KeyPressed)) and (frame < 91) do
        begin
          frame   := frame + 1;
          xyscale := zoom * 2 * sinus(beta);
          rot3(1, trunc(angle/2), Qe);
          rot3(2, angle, P);
          mult3(P, Qe, P);
          cube(P);
          display;
          angle := angle + angleinc;
          beta  := beta + betainc;
          nov   := 0;
        end;
      end;

      {Piramides Animatie : Scene opgebouwd uit twee Piramides en 1 Kubus }
      Procedure Piramides;
      begin
        frame   := 0;
        angle   := 0;
        beta    := 0;
        betainc := 2;
        scale3(4.0, 0.2, 4.0, C);
        cubesetup(90);
        cube(P);

        scale3(2.5, 4.0, 2.5, D);
        tran3(2.0, -0.2, 2.0, E);
        mult3(E, D, F);
        pirasetup(34);
        piramid(P);

        scale3(2.0, 4.0, 2.0, G);
        tran3(-3.0, -0.2, 0.0, H);
        mult3(H, G, I);
        pirasetup(42);
        piramid(P);

        E := Q;
        nov := 0;

        While (NOT (KeyPressed)) and (frame < 18) do
        begin
          frame   := frame + 1;
          xyscale := zoom * 2 * sinus(beta);

          rot3(2, angle, B);

          mult3(B, C, P);
          cube(P);

          mult3(B, F, P);
          piramid(P);

          mult3(B, I, P);
          piramid(P);

          display;

          angle := angle + angleinc;
          beta  := beta + betainc;
          nov   := 0;
         end;

         frame := 0;
         angleinc := 7;

         While (NOT (KeyPressed)) and (frame < 75) do
         begin
           frame := frame + 1;

           rot3(2, angle, B);

           mult3(B, C, P);
           cube(P);

           mult3(B, F, P);
           piramid(P);

           mult3(B, I, P);
           piramid(P);

           display;

           angle := angle + angleinc;
           nov   := 0;
         end;

         frame := 0;
         beta := 180-beta;

         While (NOT (KeyPressed)) and (frame < 19) do
         begin

           frame := frame + 1;

           xyscale := zoom * 2 * sinus(beta);
           rot3(2, angle, B);

           mult3(C, B, P);
           cube(P);

           mult3(B, F, P);
           piramid(P);

           mult3(B, I, P);
           piramid(P);

           display;

           angle := angle + angleinc;
           beta  := beta  + betainc;
           nov   := 0;
        end;
      end;

      { Huis_animatie4 : Figuur huis roteert en "komt uit de lucht vallen" }
      Procedure huisval;
      begin
        xyscale  := zoom;
        nof      := 0;
        nov      := 0;
        last     := 0;
        angle    := 1355;
        angleinc := -7;
        frame    := 0;

        huissetup;

        zoom     := 0.02;
        Direct.x := 30;
        direct.y := -2;
        direct.z := 30;
        findQ;

        While (NOT (KeyPressed)) and (frame < 40) do
        begin
          frame := frame + 1;
          zoom  := zoom + 0.01;
          Scale3(zoom, zoom, zoom, Qe);
          tran3(0, (-7 / zoom) + frame / 1.8, 0, A);
          mult3(Qe, A, C);
          rot3(2, angle, B);
          mult3(C, B, P);
          huis(P);
          display;
          angle := angle + angleinc;
          nov   := 0;
        end;

        frame   := 0;
        beta    := angle;
        betainc := angleinc;

        While (NOT (KeyPressed)) and (frame < 15) do
        begin
          frame := frame + 1;

          rot3(2, beta, B);
          mult3(B, Qe, P);
          mult3(P, A, P);
          huis(P);

          display;

          beta    := beta + betainc;
          betainc := trunc(betainc + (7 / 15));
          nov     := 0;
        end;

        frame := 0;

        While (NOT (KeyPressed)) and (frame < 30) do
        begin
          frame    := frame + 1;
          direct.z := direct.z - (frame * (20 / 70));
          findQ;
          huis(P);
          display;
          nov := 0;
        end;

        frame := 0;
        zoom  := 1;

        While (NOT (KeyPressed)) and (frame < 31) do
        begin
          frame := frame + 1;
          mult3(B, Qe, P);
          scale3(zoom, zoom, zoom, C);
          mult3(P, A, P);
          mult3(P, C, P);
          huis(P);
          display;
          zoom := zoom - 1 / 30;
          nov  := 0;
        end;

        zoom := xyscale;
      end;

      { Ster Animatie : Roterende ster als kubus met 4 piramides }
      Procedure Sterrot;
      begin
        xyscale  := zoom;
        frame    := 0;
        angle    := 0;
        angleinc := 9;
        beta     := 0;
        betainc  := 2;
        nof      := 0;
        last     := 0;
        nov      := 0;

        stersetup(140);
        scale3(0, 0, 0, P);
        ster(P, 4);

        Direct.x := 30;
        direct.y := -2;
        direct.z := 30;
        findQ;
        E := Q;

        While (NOT (KeyPressed)) and (frame < 90) do
        begin
          frame   := frame + 1;
          xyscale := zoom * 1.7 * sinus(beta);
          rot3(1, Round(angle/5), A);
          mult3(A, E, Q);
          rot3(2, angle, P);
          ster(P, 4);
          display;
          angle := angle + angleinc;
          beta  := beta  + betainc;
          nov   := 0;
        end;
      end;

    begin
      eye.x := 0;
      eye.y := 0;
      eye.z :=  0;
      zoom  := xyscale;
      Repeat
        nov  := 0;
        nof  := 0;
        last := 0;
        Kubus;
        Piramides;
        Huisval;
        Sterrot;
      Until KeyPressed;
    end;

    { _______________Hoofd Programma --------------------- }

    begin
      nov  := 0;
      nof  := 0;
      last := 0;
      start('pira', 15,  Opal);

      points[0]     := 0;
      prevpoints[0] := 0;
      hline[0]      := 0;
      prevhline[0]  := 0;

      anim3D;

      finish(Opal);
      Writeln('Coded by ...... " De Vectorman "');
      Writeln;
    end.

    { ±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±± }

    Unit ddfigs;

    Interface

    Uses
      DDprocs, DDVars;

    Const
      cubevert : Array [1..8] of vector3 =
        ((x :  1; y :  1; z :  1),
         (x :  1; y : -1; z :  1),
         (x :  1; y : -1; z : -1),
         (x :  1; y :  1; z : -1),
         (x : -1; y :  1; z :  1),
         (x : -1; y : -1; z :  1),
         (x : -1; y : -1; z : -1),
         (x : -1; y :  1; z : -1));

      cubefacet : Array [1..6, 1..4] of Integer =
        ((1, 2, 3, 4),
         (1, 4, 8, 5),
         (1, 5, 6, 2),
         (3, 7, 8, 4),
         (2, 6, 7, 3),
         (5, 8, 7, 6));

      piravert  : Array [1..5] of vector3 =
        ((x :  0; y :  1; z :  0),
         (x :  1; y :  0; z : -1),
         (x : -1; y :  0; z : -1),
         (x : -1; y :  0; z :  1),
         (x :  1; y :  0; z :  1));

      pirafacet : Array [1..5, 1..3] of Integer =
        ((1, 2, 3),
         (1, 3, 4),
         (1, 4, 5),
         (1, 5, 2),
         (5, 4, 3));

      huisvert  : Array[1..59] of vector3 =
        ((x : -6; y :  0; z :  4), (x :  6; y : 0; z :  4),
         (x :  6; y :  0; z : -4),
         (x : -6; y :  0; z : -4), (x : -6; y : 8; z :  4), (x :  6; y : 8; z :  4),
         (x :  6; y : 11; z :  0), (x :  6; y : 8; z : -4), (x : -6; y : 8; z : -4),
         (x : -6; y : 11; z :  0), (x : -4; y : 1; z :  4), (x : -1; y : 1; z :  4),
         (x : -1; y :  3; z :  4), (x : -4; y : 3; z :  4), (x : -4; y : 5; z :  4),
         (x : -1; y :  5; z :  4), (x : -1; y : 7; z :  4), (x : -4; y : 7; z :  4),
         (x :  0; y :  0; z :  4), (x :  5; y : 0; z :  4), (x :  5; y : 4; z :  4),
         (x :  0; y :  4; z :  4), (x :  1; y : 5; z :  4), (x :  4; y : 5; z :  4),
         (x :  4; y :  7; z :  4), (x :  1; y : 7; z :  4), (x :  6; y : 5; z : -1),
         (x :  6; y :  5; z : -3), (x :  6; y : 7; z : -3), (x :  6; y : 7; z : -1),
         (x :  5; y :  1; z : -4), (x :  2; y : 1; z : -4), (x :  2; y : 3; z : -4),
         (x :  5; y :  3; z : -4), (x :  5; y : 5; z : -4), (x :  2; y : 5; z : -4),
         (x :  2; y :  7; z : -4), (x :  5; y : 7; z : -4), (x :  1; y : 0; z : -4),
         (x : -1; y :  0; z : -4), (x : -1; y : 3; z : -4), (x :  0; y : 4; z : -4),
         (x :  1; y :  3; z : -4), (x : -2; y : 1; z : -4), (x : -5; y : 1; z : -4),
         (x : -5; y :  3; z : -4), (x : -2; y : 3; z : -4), (x : -2; y : 5; z : -4),
         (x : -5; y :  5; z : -4), (x : -5; y : 7; z : -4), (x : -2; y : 7; z : -4),
         (x : -6; y :  0; z :  1), (x : -6; y : 0; z :  3), (x : -6; y : 3; z :  3),
         (x : -6; y :  3; z :  1), (x : -6; y : 5; z :  1), (x : -6; y : 5; z :  3),
         (x : -6; y :  7; z :  3), (x : -6; y : 7; z :  1));

      huissize  : Array [1..19] of Integer =
        (4, 4, 5, 4, 4, 5, 4, 4, 4, 4, 4, 4, 4, 4, 5, 4, 4, 4, 4);

      huissuper : Array [1..19] of Integer =
        (0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 3, 4, 4, 4, 4, 4, 6, 6);

      huisfacet : Array [1..79] of Integer =
        ( 1,  2,  6,  5,
          5,  6,  7, 10,
          2,  3,  8,  7,
          6,  3,  4,  9,
          8,  8,  9, 10,
          7,  4,  1,  5,
         10,  9,  4,  3,
          2,  1, 11, 12,
         13, 14, 15, 16,
         17, 18, 19, 20,
         21, 22, 23, 24,
         25, 26, 27, 28,
         29, 30, 31, 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);

      stervert : Array [1..6] of vector3 =
        ((x :  1; y :  0; z :  0),
         (x :  0; y :  1; z :  0),
         (x :  0; y :  0; z :  1),
         (x :  0; y :  0; z : -1),
         (x :  0; y : -1; z :  0),
         (x : -1; y :  0; z :  0));

    Procedure cubesetup(c : Integer);
    Procedure cube(P : matrix4x4);
    Procedure pirasetup(c : Integer);
    Procedure piramid(P : matrix4x4);
    Procedure huissetup;
    Procedure huis(P : matrix4x4);
    Procedure hollow(P1 : matrix4x4);
    Procedure stersetup(col : Integer);
    Procedure ster(P : matrix4x4; d : Real);
    Procedure ellips(P : matrix4x4; col : Integer);
    Procedure goblet(P : matrix4x4; col : Integer);

    Implementation

    Procedure cubesetup(c : Integer);
    { zet kubusdata in facetlist van de scene}
    Var
      i, j : Integer;
    begin
      For i :=  1 to 6 DO
      begin
        For j := 1 to 4 DO
          faclist[last + j] := cubefacet[i, j] + nov;
        nof := nof + 1;
        facfront[nof] := last;
        colour[nof]   := c;
        nfac[nof]     := nof;
        super[nof]    := 0;
        firstsup[nof] := 0;
        size[nof]     := 4;
        last := last + size[nof];
      end;
    end;

    Procedure cube(P : matrix4x4);
    Var
      i, j : Integer;
    begin
      For i :=  1 to 8 DO
      begin
        nov := nov + 1;
        transform(cubevert[i], P, act[nov]);
      end;
    end;

    Procedure pirasetup(c : Integer);
    Var
      i, j : Integer;
    begin
      For i :=  1 to 5 DO
      begin
        For j := 1 to 3 DO
          faclist[last + j] := pirafacet[i, j] + nov;
        nof := nof + 1;
        facfront[nof] := last;
        size[nof]     := 3;
        last          := last + size[nof];
        colour[nof]   := c;
        nfac[nof]     := nof;
        super[nof]    := 0;
        firstsup[nof] := 0;
      end;

      size[nof] := 4;
      faclist[facfront[nof] + 4] := 2 + nov;
      last := last + 1;
    end;

    Procedure piramid(P : matrix4x4);
    Var
      i, j : Integer;
    begin
      For i :=  1 to 5 DO
      begin
        nov := nov + 1;
        transform(piravert[i], P, act[nov]);
      end;
    end;

    Procedure huissetup;
    Var
      i, j,
      host,
      nofstore : Integer;
    begin
      For i := 1 to 79 DO
        faclist[last + i] := huisfacet[i] + nov;

      nofstore := nof;

      For i := 1 to 19 DO
      begin
        nof           := nof + 1;
        facfront[nof] := last;
        size[nof]     := huissize[i];
        last          := last + size[nof];
        nfac[nof]     := nof;

        if (i = 2) or (i = 5) then
          colour[nof] := 111
        else
        if i = 7 then
          colour[nof] := 20
        else
        if i < 8 then
          colour[nof] := 42
        else
          colour[nof] := 25;

        super[nof] := huissuper[i];
        firstsup[nof] := 0;

        if super[nof] <> 0 then
        begin
          host := super[nof] + nofstore;
          super[nof] := host;
          pushfacet(firstsup[host], nof);
        end;
      end;
      For i  :=  1 to 59 DO
        setup[i] := huisvert[i];
    end;

    Procedure huis(P : matrix4x4);
    Var
      i : Integer;
    begin
      For i := 1 to 59 DO
      begin
        nov := nov + 1;
        transform(setup[i], P, act[nov]);
      end;
    end;

    Procedure hollow(P1 : matrix4x4);
    Var
      A, B,
      P, P2 : matrix4x4;
      i     : Integer;
    begin
      For i := 1 to 8 DO
      begin
        tran3(4.0 * cubevert[i].x, 4.0 * cubevert[i].y, 4.0 * cubevert[i].z, P2);
        mult3(P1, P2, P);
        cube(P);
      end;

      For i := 1 to 4 DO
      begin
        scale3(3.0, 1.0, 1.0, A);
        tran3(0.0, 4.0 * cubevert[i].y, 4.0 * cubevert[i].z, B);
        mult3(A, B, P2);mult3(P1, P2, P);
        cube(P);
        scale3(1.0, 3.0, 1.0, A);
        tran3(4.0 * cubevert[i].y, 0.0, 4.0 * cubevert[i].z, B);
        mult3(A, B, P2);mult3(P1, P2, P);
        cube(P);
        scale3(1.0, 1.0, 3.0, A);
        tran3(4.0 * cubevert[i].z, 4.0 * cubevert[i].y, 0.0, B);
        mult3(A, B, P2);mult3(P1, P2, P);
        cube(P);
      end;
    end;

    Procedure stersetup(col : Integer);
    Var
      i, j,
      v1, v2 : Integer;
    begin
      For i := 1 to 6 DO
      begin
        v1 := cubefacet[i, 4] + nov;
        For j := 1 to 4 DO
        begin
          v2  := cubefacet[i, j] + nov;
          nof := nof + 1;
          faclist[last + 1] := v1;
          faclist[last + 2] := v2;
          faclist[last + 3] := nov + 8 + i;
          facfront[nof]     := last;
          size[nof] := 3;

          last := last + size[nof];
          colour[nof] := col;
          nfac[nof]   := nof;
          super[nof]  := 0;
          firstsup[nof] := 0;
          v1 := v2;
        end;
      end;
    end;

    Procedure ster(P : matrix4x4; d : Real);
    Var
      i, j,
      v1, v2 : Integer;
      A, S   : matrix4x4;
    begin
      For i :=  1 to 8 DO
      begin
        nov := nov + 1;
        transform(cubevert[i], P, act[nov]);
      end;

      scale3(D, D, D, A);
      mult3(A, P, S);

      For i := 1 to 6 DO
      begin
        nov := nov + 1;
        transform(stervert[i], S, act[nov]);
      end;
    end;

    Procedure ellips(P : matrix4x4; col : Integer);
    Var
      v : vector2Array;
      theta,
      thetadiff,
      i : Integer;
    begin
      theta := -90;
      thetadiff := -9;
      For i :=  1 to 21 DO
      begin
        v[i].x := cosin(theta);
        v[i].y := sinus(theta);
        theta  := theta + thetadiff;
      end;
      bodyofrev(P, col, 21, 20, v);
    end;

    Procedure goblet(P : matrix4x4; col : Integer);
    Const
      gobletdat : Array [1..12] of vector2 =
        ((x :  0; y : -16),
         (x :  8; y : -16),
         (x :  8; y : -15),
         (x :  1; y : -15),
         (x :  1; y :  -2),
         (x :  6; y :  -1),
         (x :  8; y :   2),
         (x : 14; y :  14),
         (x : 13; y :  14),
         (x :  7; y :   2),
         (x :  5; y :   0),
         (x :  0; y :   0));

    Var
      gobl : vector2Array;
      i    : Integer;
    begin
      For i := 1 to 12 DO
        gobl[i] := gobletdat[i];
      bodyofrev(P, col, 12, 20, gobl)
    end;

    begin;
    end.

    { ±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±± }

    Unit ddprocs;

    Interface

    Uses
      DDVars;

    Const
      maxv = 200;
      maxf = 400;
      maxlist = 1000;
      vectorArraysize  = 32;
      sizeofpixelArray = 3200;
      sizeofhlineArray = 320 * 4;

    Type
      vector2      = Record x, y : Real; end;
      vector3      = Record x, y, z : Real; end;
      pixelvector  = Record x, y : Integer; end;
      pixelArray   = Array [0..sizeofpixelArray] of Integer;
      hlineArray   = Array [0..sizeofhlineArray] of Integer;
      vector3Array = Array [1..vectorArraysize] of vector3;
      matrix3x3    = Array [1..3, 1..3] of Real;
      matrix4x4    = Array [1..4, 1..4] of Real;
      vertex3Array = Array [1..maxv] of vector3;
      vertex2Array = Array [1..maxv] of vector2;
      vector2Array = Array [1..vectorArraysize ] of vector2;
      facetArray   = Array [1..maxf] of Integer;
      facetlist    = Array [1..maxlist] of Integer;

    Const
      EenheidsM : matrix4x4 =
        ((1, 0, 0, 0),
         (0, 1, 0, 0),
         (0, 0, 1, 0),
         (0, 0, 0, 1));
    Var
      Q           : matrix4x4;
      eye, direct : vector3;
      nov, ntv,
      ntf, nof,
      last        : Integer;
      setup,
      act, obs    : vertex3Array;
      pro         : vertex2Array;
      faclist     : facetlist;
      colour,
      size,
      facfront,
      nfac,
      super,
      firstsup    : facetArray;
      points,
      prevpoints  : pixelArray;
      hline,
      prevhline   : hlineArray;

    Procedure tran3(tx, ty, tz : Real; Var A : matrix4x4);
    Procedure scale3(sx, sy, sz : Real; Var A : matrix4x4);
    Procedure rot3(m : Integer; theta : Integer; Var A : matrix4x4);
    Procedure mult3(A, B : matrix4x4; Var C : matrix4x4);
    Procedure findQ;
    Procedure genrot(phi : Integer; b, d : vector3; Var A : matrix4x4);
    Procedure transform(v : vector3; A : matrix4x4; Var w : vector3);
    Procedure extrude(P : matrix4x4; d : Real; col, n : Integer;
                      v : vector2Array);
    Procedure bodyofrev(P : matrix4x4; col, nvert, nhoriz : Integer;
                        v : vector2Array);
    Procedure polydraw(c, n : Integer; poly : vector2Array);
    Procedure linepto(c : Integer; pt1, pt2 : vector2);
    Procedure WisScherm(punten : pixelArray; SchermSeg, VirSeg : Word);
    Procedure fillpoly(c, n : Integer; poly : vector2Array);
    Procedure Wis_Hline(hline_ar : hlineArray; virseg : Word);

    Implementation

    Procedure tran3(tx, ty, tz : Real; Var A : matrix4x4);
    { zet matrix A op punt tx, ty, tz }
    begin
      A := EenheidsM;
      A[1, 4] := -tx;
      A[2, 4] := -ty;
      A[3, 4] := -tz;
    end;

    Procedure scale3(sx, sy, sz : Real; Var A : matrix4x4);
    { zet matrix A om in schaal van sx, sy, sz }
    begin
      A := EenheidsM;
      A[1, 1] := sx;
      A[2, 2] := sy;
      A[3, 3] := sz;
    end;

    Procedure rot3(m : Integer; theta : Integer; Var A : matrix4x4);
    { roteer matrix A om m: 1=x-as; 2=y-as; 3=z-as met hoek theta (in graden)}
    Var
      m1, m2 : Integer;
      c, s   : Real;
    begin
      A  := EenheidsM;
      m1 := (m MOD 3) + 1;
      m2 := (m1 MOD 3) + 1;
      c  := cosin(theta);
      s  := sinus(theta);
      A[m1, m1] := c;
      A[m2, m2] := c;
      A[m1, m2] := s;
      A[m2, m1] := -s;
    end;

    Procedure mult3(A, B : matrix4x4; Var C : matrix4x4);
    { vermenigvuldigd matrix A en B naar matrix C }
    Var
      i, j, k : Integer;
      ab      : Real;
    begin
      For i := 1 to 4 do
        For j :=  1 to 4 do
        begin
          ab := 0;
          For k := 1 to 4 do
            ab := ab + A[i, k] * B[k, j];
          C[i, j] := ab;
        end;
    end;

    Procedure findQ;
    { Bereken de Observatie-matrix 'Q' voor een punt in de ruimte }
    Var
      E, F, G,
      H, U    : matrix4x4;
      alpha,
      beta,
      gamma   : Integer;
      v, w    : Real;
    begin
      tran3(eye.x, eye.y, eye.z, F);

      alpha := angle(-direct.x, -direct.y);
      rot3(3, alpha, G);

      v :=  sqrt( (direct.x * direct.x) + (direct.y * direct.y));
      beta := angle(-direct.z, v);
      rot3(2, beta, H);

      w :=  sqrt( (v * v) + (direct.z * direct.z));
      gamma := angle( -direct.x * w,  direct.y * direct.z);
      rot3(3, gamma, U);

      mult3(G, F, Q);
      mult3(H, Q, E);
      mult3(U, E, Q);
    end;

    Procedure genrot (phi : Integer; b, d : vector3; Var A : matrix4x4);
    Var
      F, G, H,
      W, FI, GI,
      HI, S, T  : matrix4x4;
      v         : Real;
      beta,
      theta     : Integer;
    begin
      tran3(b.x, b.y, b.z, F);
      tran3(-b.x, -b.y, -b.z, FI);
      theta := angle(d.x, d.y);
      rot3(3, theta, G);
      rot3(3, -theta, GI);
      v := sqrt(d.x * d.x + d.y * d.y);
      beta := angle(d.z, v);
      rot3(2, beta, H);
      rot3(2, -beta, HI);
      rot3(2, beta, H);
      rot3(2, -beta, HI);
      rot3(3, phi, W);
      mult3(G, F, S);
      mult3(H, S, T);
      mult3(W, S, T);
      mult3(HI, S, T);
      mult3(GI, T, S);
      mult3(FI, S, A);
    end;

    Procedure transform(v : vector3; A : matrix4x4; Var w : vector3);
    { transformeer colomvector 'v' uit A in colomvector 'w'}
    begin
      w.x := A[1, 1] * v.x + A[1, 2] * v.y + A[1, 3] * v.z + A[1, 4];
      w.y := A[2, 1] * v.x + A[2, 2] * v.y + A[2, 3] * v.z + A[2, 4];
      w.z := A[3, 1] * v.x + A[3, 2] * v.y + A[3, 3] * v.z + A[3, 4];
    end;

    Procedure extrude(P : matrix4x4; d : Real; col, n : Integer;
                      v : vector2Array);
    { Maakt van een 2d-figuur een 3d-figuur }
    { vb: converteert 2d-letters naar 3d-letters }
    Var
      i, j,
      lasti : Integer;
      v3    : vector3;
    begin
      For i := 1 to n DO
      begin
        faclist[last + i] := nov + i;
        faclist[last + n + i] := nov + 2 * n + 1 - i;
      end;
      facfront[nof + 1] := last;
      facfront[nof + 2] := last + n;
      size[nof + 1] := n;
      size[nof + 2] := n;
      nfac[nof + 1] := nof + 1;
      nfac[nof + 2] := nof + 2;
      super[nof + 1] := 0;
      super[nof + 2] := 0;
      firstsup[nof + 1] := 0;
      firstsup[nof + 2] := 0;
      colour[nof + 1] := col;
      colour[nof + 2] := col;
      last  := last + 2 * n;
      nof   := nof + 2;
      lasti := n;

      For i := 1 to n DO
      begin
        faclist[last + 1] := nov + i;
        faclist[last + 2] := nov + lasti;
        faclist[last + 3] := nov + n + lasti;
        faclist[last + 4] := nov + n + i;
        nof := nof + 1 ;
        facfront[nof] := last;
        size[nof]     := 4;
        nfac[nof]     := nof;
        super[nof]    := 0;
        firstsup[nof] := 0;
        colour[nof]   := col;
        last  := last + 4;
        lasti := i;
      end;
      For i :=  1 To n DO
      begin
        v3.x := v[i].x;
        v3.y := v[i].y;
        v3.z := 0.0;
        nov  := nov + 1;
        transform(v3, P, act[nov]);
        v3.z := -d;
        transform(v3, P, act[nov + n]);
      end;
      nov := nov + n;
    end;

    Procedure bodyofrev(P : matrix4x4; col, nvert, nhoriz : Integer;
                        v : vector2Array);
    { maakt een "rond" figuur van een 2-dimensionale omlijning van het figuur }
    Var
      theta,
      thetadiff,
      i, j, newnov : Integer;
      c, s         : Array [1 .. 100] of Real;
      index1,
      index2       : Array [1 .. 101] of Integer;
    begin
      theta := 0;
      thetadiff := trunc(360 / nhoriz);

      For i := 1 to nhoriz DO
      begin
        c[i]  := cosin(theta);
        s[i]  := sinus(theta);
        theta := theta + thetadiff;
      end;
      newnov := nov;

      if abs(v[1].x) < epsilon  then
      begin
        newnov := newnov + 1;
        setup[newnov].x := 0.0;
        setup[newnov].y := v[1].y;
        setup[newnov].z := 0.0;
        For i := 1 to nhoriz + 1 DO
          index1[i] := newnov;
      end
      else
      begin
        For i := 1 to nhoriz DO
        begin
          newnov := newnov + 1;
          setup[newnov].x := v[1].x * c[i];
          setup[newnov].y := v[1].y;
          setup[newnov].z := -v[1].x * s[i];
          index1[i] := newnov;
        end;
        index1[nhoriz + 1] := index1[i];
      end;

      For j :=  2 to nvert DO
      begin
        if abs(v[j].x) < epsilon then
        begin
          newnov := newnov + 1;
          setup[newnov].x := 0.0;
          setup[newnov].y := v[j].y;
          setup[newnov].z := 0.0;
          For i := 1 to nhoriz + 1 DO
            index2[i] := newnov;
        end
        else
        begin
          For i := 1 To nhoriz DO
          begin
            newnov := newnov + 1;
            setup[newnov].x :=  v[j].x * c[i];
            setup[newnov].y :=  v[j].y;
            setup[newnov].z := -v[j].x * s[i];
            index2[i] := newnov;
          end;
          index2[nhoriz + 1] := index2[1];
        end;

        if index1[1] <> index1[2] then
          if index2[1] = index2[2] then
          begin
            For i := 1 to nhoriz DO
            begin
              nof := nof + 1; size[nof] := 3;
              facfront[nof] := last;
              faclist[last + 1] := index1[i + 1];
              faclist[last + 2] := index2[i];
              faclist[last + 3] := index1[i];
              last := last + size[nof];
              nfac[nof]     := nof;
              colour[nof]   := col;
              super[nof]    := 0;
              firstsup[nof] := 0;
            end;
          end
          else
          begin
            For i := 1 to nhoriz DO
            begin
              nof := nof + 1;
              size[nof] := 4;
              facfront[nof] := last;
              faclist[last + 1] := index1[i + 1];
              faclist[last + 2] := index2[i + 2];
              faclist[last + 3] := index2[i];
              faclist[last + 4] := index1[i];
              last := last + size[nof];
              nfac[nof]     := nof;
              colour[nof]   := col;
              super[nof]    := 0;
              firstsup[nof] := 0;
            end;
          end
          else
          if index2[1] <> index2[2] then
            For i := 1 to nhoriz DO
            begin
              nof := nof + 1;
              size[nof] := 3;
              facfront[nof] := last;
              faclist[last + 1] := index2[i + 1];
              faclist[last + 2] := index2[i];
              faclist[last + 3] := index1[i];
              last := last + size[nof];
              nfac[nof]     := nof;
              colour[nof]   := col;
              super[nof]    := 0;
              firstsup[nof] := 0;
            end;

            For i :=  1 to nhoriz + 1 DO
              index1[i] := index2[i];
      end;

      For i :=  nov + 1 to newnov DO
        transform(setup[i], P, act[i]);

      nov := newnov;

    end;

    Procedure BressenHam( Virseg : Word;          { Adres-> VIRSEG:0 }
                          pnts   : pixelArray;
                          c      : Byte;          { c->     kleur    }
                          p1, p2 : pixelvector);  { vector           } Assembler;
    Var
      x, y, error,
      s1,  s2,
      deltax,
      deltay, i   : Integer;
      interchange : Boolean;
      dcolor      : Word;
    Asm
    {  initialize Variables  }
      PUSH   ds
      LDS    si, pnts
      MOV    ax, virseg
      MOV    es, ax
      MOV    cx, 320
      MOV    ax, p1.x
      MOV    x,  ax
      MOV    ax, p1.y
      MOV    y, ax
      MOV    dcolor, ax

      MOV    ax, p2.x                { deltax := abs(x2 - x1) }
      SUB    ax, p1.x                { s1 := sign(x2 - x1) }
      PUSH   ax
      PUSH   ax
      CALL   ddVars.sign
      MOV    s1, ax;
      POP    ax
      TEST   ax, $8000
      JZ     @@GeenSIGN1
      NEG    ax
     @@GeenSign1:
      MOV    deltax, ax
      MOV    ax, p2.y
      SUB    ax, p1.y
      PUSH   ax
      PUSH   ax
      CALL   ddVars.sign
      MOV    s2, ax
      POP    ax
      TEST   ax, $8000
      JZ     @@GeenSign2
      NEG    ax
     @@GeenSign2:
      MOV    deltay, ax

     { Interchange DeltaX and DeltaY depending on the slope of the line }

      MOV    interchange, False
      CMP    ax, deltax
      JNG    @@NO_INTERCHANGE
      XCHG   ax, deltax
      XCHG   ax, deltay
      MOV    interchange, True

     @@NO_INTERCHANGE:

      { Initialize the error term to compensate For a nonzero intercept }

      MOV    ax, deltaY
      SHL    ax, 1
      SUB    ax, deltaX
      MOV    error, ax

      { Main loop }
      MOV    ax, 1
      MOV    i, ax
     @@FOR_begin:
      CMP    ax, deltaX
      JG     @@EINDE_FOR_LOOP

      { Plot punt! }
      MOV   bx, x
      MOV   ax, y
      MUL   cx
      ADD   bx, ax
      MOV   al, c
      MOV   Byte PTR [es:bx], al
      INC   [Word ptr ds:si]     { aantal verhogen }
      MOV   ax, [si]
      SHL   ax, 1                { offset berekenen }
      PUSH  si
      ADD   si, ax
      MOV   [si], bx
      POP   si

      { While Loop }
     @@W1_begin:
      CMP    error, 0
      JL     @@EINDE_WHILE

      { if interchange then }

      CMP    interchange, True
      JE     @@i_is_t
      MOV    ax, s2
      ADD    y, ax
      JMP    @@w1_eruit

     @@i_is_t:
      MOV    ax, s1
      ADD    x, ax

     @@w1_eruit:
      MOV    ax, deltax
      SHL    ax, 1
      SUB    error, ax
      JMP    @@w1_begin

     @@EINDE_WHILE:
      CMP    interchange, True
      JE     @@i_is_t_1
      MOV    ax, s1
      ADD    x, ax
      JMP    @@if_2_eruit

     @@i_is_t_1:
      MOV    ax, s2
      ADD    y, ax

     @@if_2_eruit:
      MOV    ax, deltay
      SHL    ax, 1
      ADD    error, ax
      INC    i
      MOV    ax, i
      JMP    @@FOR_begin
     @@Einde_for_loop:
      POP    ds
    end;

    Procedure linepto(c : Integer; pt1, pt2 : vector2);
    Var
      p1, p2 : pixelvector;
    begin
      p1.x := fx(pt1.x);
      p1.y := fy(pt1.y);
      p2.x := fx(pt2.x);
      p2.y := fy(pt2.y);
      BressenHam($a000, points, c,  p1,  p2);
    end;

    Procedure WisScherm(punten : pixelArray; SchermSeg , Virseg : Word); Assembler;
    Asm
      PUSH      ds
      MOV       ax, SchermSeg
      MOV       es, ax
      LDS       bx, punten
      MOV       cx, [bx]
      JCXZ      @@NietTekenen
     @@Wis:
      INC       bx
      INC       bx
      MOV       si, [bx]
      MOV       di, si
      PUSH      ds
      MOV       ax, virseg
      MOV       ds, ax
      MOVSB
      POP       ds
      LOOP      @@Wis
     @@NietTekenen:
      POP       ds
    end;

    Procedure polydraw(c, n : Integer; poly : vector2Array);
    Var
      i : Integer;
    begin
      For i :=  1 to n - 1 do
        linepto(c, poly[i], poly[i + 1]);
      linepto(c, poly[n], poly[1]);
    end;

    Procedure fillpoly(c, n : Integer; poly : vector2Array);
    Var
      scan_table : tabel;
      scanline,
      line,
      offsetx    : Integer;

      Procedure Draw_horiz_line(hline_ar  : hlineArray;
                                color     : Byte;
                                lijn      : Word;
                                begin_p   : Word;
                                linelen   : Word); Assembler;
      Asm
        PUSH  ds
        MOV   cx, 320
        MOV   ax, 0a000h
        MOV   es, ax
        MOV   di, begin_p
        MOV   ax, lijn
        MUL   cx
        ADD   di, ax
        PUSH  di
        MOV   al, color
        MOV   cx, linelen
        PUSH  cx
        REP   STOSB
        LDS   si, hline_ar
        INC   [Word ptr ds:si]
        MOV   ax, [si]
        SHL   ax, 1
        SHL   ax, 1
        ADD   si, ax
        POP   bx
        POP   dx
        MOV   [si], dx
        MOV   [si + 2], bx
        POP   ds
      end;

      Procedure swap(Var x, y : Integer);
      begin
        x := x + y;
        y := x - y;
        x := x - y;
      end;

    {
    Procedure Calc_x(x1, y1, x2, y2 : Word; Var scan_table : tabel);
    Var
      m_inv,
      xReal : Real;
    begin
      Asm
        LDS     dx, scan_table
        MOV     ax, y1
        MOV     bx, y2
        CMP     ax, bx
        JNE     @@NotHorizLine
        MOV     bx, x1
        SHL     ax, 1
        ADD     ax, dx
        CMP     bx, [dx]
        JGE     @@Notstorexmin
        MOV     [dx], bx

       @@Notstorexmin:
        INC     dx
        MOV     bx, x2
        CMP     bx, [dx]
        JLE     @@Klaar
        MOV     [dx], bx
        JMP     @@Klaar

       @@NotHorizLine:
    }

      Procedure Calc_x(x1, y1, x2, y2 : Integer; Var scan_table : tabel);
      Var
        m_inv, xReal : Real;
        i, y, temp   : Integer;
      begin
        if y1 = y2 then
        begin
          if x2 < x1 then
            swap(x1, x2)
          else
          begin
            if x1 < scan_table[y1].xmin then
              scan_table[y1].xmin := x1;
            if x2 > scan_table[y2].xmax then
              scan_table[y2].xmax := x2;
          end;
        end
        else
        begin
          m_inv := (x2 - x1) / (y2 - y1);

          if y1 > y2 then {swap}
          begin
            swap(y1, y2);
            swap(x1, x2);
          end;

          if x1 < scan_table[y1].xmin then
            scan_table[y1].xmin := x1;
          if x2 > scan_table[y2].xmax then
            scan_table[y2].xmax := x2;
          xReal := x1; y := y1;

          While y < y2 do
          begin
            y := y + 1;
            xReal := xReal + m_inv;
            offsetx := round(xReal);
            if xReal < scan_table[y].xmin then
              scan_table[y].xmin := offsetx;
            if xReal > scan_table[y].xmax then
              scan_table[y].xmax := offsetx;
          end;
        end;
      end;

    begin
      scan_table := emptytabel;
      For line := 1 to n - 1 do
        calc_x(fx(poly[line].x), fy(poly[line].y),
               fx(poly[line + 1].x), fy(poly[line + 1].y), scan_table);

      calc_x(fx(poly[n].x), fy(poly[n].y),
             fx(poly[1].x), fy(poly[1].y), scan_table);

      scanline := 0;

      While scanline < nypix - 1 do
      begin
        With Scan_table[scanline] DO
          if xmax > xmin then
            draw_horiz_line(hline, c,  scanline,  xmin,  xmax - xmin + 1);
          scanline := scanline + 1;
      end;
    end;

    Procedure  Wis_Hline(hline_ar : hlineArray; virseg : Word); Assembler;
    Asm
      PUSH      ds
      MOV       ax, 0a000h
      MOV       es, ax
      LDS       bx, hline_ar
      MOV       cx, [bx]
      JCXZ      @@Niet_tekenen
      ADD       bx, 4
     @@Wis:
      XCHG      cx, dx
      MOV       si, [bx]
      MOV       cx, [bx + 2]
      MOV       di, si
      PUSH      ds
      MOV       ax, virseg
      MOV       ds, ax
      CLD
      REP       MOVSB
      POP       ds
      XCHG      cx, dx
      ADD       bx, 4
      LOOP      @@Wis
     @@Niet_tekenen:
      POP       ds
    end;

    begin
    end.

    { ±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±± }

    Unit
      ddVars;

    Interface

    Const
      pi      = 3.1415926535;
      epsilon = 0.000001;
      rad     = pi / 180;
      nxpix   = 320; { scherm resolutie }
      nypix   = 200;
      maxfinf = 200;

    Type
      xmaxymax  = Record xmin, xmax : Integer; end;
      facetinfo = Record info, Pointer : Integer; end;
      tabel     = Array [1..nypix - 1] of xmaxymax;
      sincos    = Array [0..359] of Real;

    Var
      sinusArray   : sincos;
      cosinusArray : sincos;
      facetinfacet : Array [1..maxfinf] of facetinfo;
      facetfree    : Integer;
      xyscale      : Real;
      emptytabel   : tabel;

    Function  fx(x : Real) : Integer;
    Function  fy(y : Real) : Integer;
    Function  Sign(I : Integer) : Integer;
    Function  macht(a, n : Real) : Real;
    Function  angle(x, y : Real) : Integer;
    Function  sinus(hoek : Integer) : Real;
    Function  cosin(hoek : Integer) : Real;
    Procedure pushfacet(Var stackname : Integer; value : Integer);

    Implementation

    Function fx(x : Real) : Integer;
    begin
      fx := nxpix - trunc(x * xyscale + nxpix * 0.5 - 0.5);
    end;

    Function fy(y : Real) : Integer;
    begin
      fy := nypix - trunc(y * xyscale + nypix * 0.5 - 0.5);
    end;

    Function Sign(I : Integer) : Integer; Assembler;
    Asm
      MOV  ax, i
      CMP  ax, 0
      JGE  @@Zero_or_one
      MOV  ax, -1
      JMP  @@Exit

     @@Zero_or_One:
      JE   @@Nul
      MOV  ax, 1
      JMP  @@Exit

     @@Nul:
      xor  ax, ax

     @@Exit:
    end;

    Function macht(a, n : Real) : Real;
    begin
      if a > 0 then
        macht :=  exp(n * (ln(a)))
      else
      if a < 0 then
        macht := -exp(n * (ln(-a)))
      else
        macht := a;
    end;

    Function angle(x, y : Real) : Integer;
    begin
      if abs(x) < epsilon then
        if abs(y) < epsilon then
          angle := 0
        else
        if y > 0.0 then
          angle := 90
        else
          angle := 270
      else
      if x < 0.0 then
        angle := round(arctan(y / x) / rad) + 180
      else
        angle := round(arctan(y / x) / rad);
    end;

    Function sinus(hoek : Integer) : Real;
    begin
      hoek  := hoek mod 360;
      sinus := sinusArray[hoek];
    end;

    Function cosin(hoek : Integer) : Real;
    begin
      hoek  := hoek mod 360 ;
      cosin := cosinusArray[hoek];
    end;

    Procedure pushfacet(Var stackname : Integer; value : Integer);
    Var
      location : Integer;
    begin
      if facetfree = 0 then
      begin
        Write('Cannot hold more facets');
        HALT;
      end
      else
      begin
        location  := facetfree;
        facetfree := facetinfacet[facetfree].Pointer;
        facetinfacet[location].info := value;
        facetinfacet[location].Pointer := stackname;
        stackname := location;
      end;
    end;

    Var
      i : Integer;
    begin
      { vul sinus- en cosinusArray met waarden }
      For i := 0 to 359 DO
      begin
        sinusArray[i]   := sin(i * rad);
        cosinusArray[i] := cos(i * rad);
      end;
      { Init facetinfacet }
      facetfree := 1;
      For i :=  1 to maxfinf - 1 DO
        facetinfacet[i].Pointer := i + 1;

      facetinfacet[maxfinf].Pointer := 0;

      { Init EmptyTabel }
      For i := 0 to nypix - 1 DO
      begin
        Emptytabel[i].xmin := 319;
        Emptytabel[i].xmax := 0;
      end;
    end.

    { ±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±± }

    Unit ddvideo;

    Interface

    Uses
      Dos, DDVars;

    Type
      schermPointer = ^schermType;
      schermType    = Array [0..nypix - 1, 0..nxpix - 1] of Byte;
      color         = Record  R, G, B : Byte; end;
      paletteType   = Array [0..255] of color;
      WordArray     = Array [0..3] of Word;
      palFile       = File of paletteType;
      picFile       = File of schermType;

    Var
      scherm    : schermType Absolute $8A00 : $0000;
      schermptr : schermPointer;
      switch    : Integer;

    Procedure start(Filenaam : String; horiz : Real; Var Oldpal : paletteType);
    Procedure finish(Oldpal : paletteType);
    Procedure VirScherm_actief(switch : Word);
    Procedure Scherm_actief(switch : Word);

    Implementation

    Procedure Virscherm_actief(switch : Word); Assembler;
    Asm
      MOV     dx, 3cch
      MOV     cx, switch
      JCXZ    @@volgende
      in      al, dx             { switch=1 }
      and     al, 0dfh
      MOV     dx, 3c2h
      OUT     dx, al             { set even mode }
      JMP     @@Klaar

     @@Volgende:
      in      al, dx             { switch=0 }
      or      al, 20h
      MOV     dx, 3c2h
      OUT     dx, al             { set odd mode }

     @@Klaar:
      MOV     dx, 3dah           { Wacht op Vert-retrace }
      in      al, dx             { Zodat virscherm = invisible }
      TEST    al, 08h
      JZ      @@Klaar
    end;

    Procedure Scherm_actief(switch : Word);
    begin
      Asm
       @@Wacht:
        MOV  dx, 3dah
        in   al, dx
        TEST al, 01h
        JNZ  @@Wacht
      end;
      port[$3d4] := $c;
      port[$3d5] := switch * $80;
    end;

    Procedure SetVgaPalette(Var p : paletteType);
    Var
      regs : Registers;
    begin
      With regs do
      begin
        ax := $1012;
        bx := 0;
        cx := 256;
        es := seg(p);
        dx := ofs(p);
      end;
      intr ($10, regs);
    end;

    Procedure start(Filenaam : String; horiz : Real; Var Oldpal : paletteType);

      Procedure readimage(Filenaam : String; Var pal : paletteType);

        Function FileExists(FileName : String) : Boolean;
        Var
          f : File;
        begin
          {$I-}
          Assign(f,  FileName);
          Reset(f);
          Close(f);
          {$I + }
          FileExists := (IOResult = 0) and (FileName <> '');
        end;

      Var
        pFile : picFile;
        lFile : palFile;
        a     : Integer;
      begin
        if (FileExists(Filenaam + '.pal')) and
           (FileExists(Filenaam + '.dwg')) then
        begin
          assign(lFile, Filenaam + '.pal');
          reset(lFile);
          read(lFile, pal);
          close(lFile);
          assign(pFile, Filenaam + '.dwg');
          reset(pFile);
          read(pFile, schermptr^);
          close(pFile);
        end
        else
        begin
          Writeln('Palette en Picture bestanden niet gevonden....');
          Halt;
        end;
      end;

      Procedure SetVgaMode; Assembler;
      Asm
        mov  ah, 0
        mov  al, 13h
        int  $10
      end;

      Procedure GetVgaPalette(Var p : paletteType);
      Var
        regs : Registers;
      begin
        With regs do
        begin
          ax := $1017;
          bx := 0;
          cx := 256;
          es := seg(p);
          dx := ofs(p);
        end;
        intr ($10, regs);
      end;

    Var
      pal : paletteType;

    begin
      getmem(schermptr, sizeof(schermType));
      readimage(Filenaam, pal);
      GetVgaPalette(OldPal);
      SetVgaPalette(pal);
      SetVgaMode;
      move(schermptr^, scherm, nypix * nxpix);
      Virscherm_actief(0);
      move(schermptr^, mem[$A000 : 0], nypix * nxpix);     { blanko scherm }
      VirScherm_actief(1);
      move(schermptr^, mem[$A000 : 0], nypix * nxpix);     { blanko scherm }
      Scherm_actief(1);
      switch  := 0;
      xyscale := (nypix - 1) / horiz;
    end;

    Procedure finish(Oldpal : paletteType);

      Procedure SetNormalMode; Assembler;
      Asm
        mov  ah,  0
        mov  al,  3
        int  $10
      end;

    begin
      SetVgaPalette(Oldpal);
      SetNormalMode;
      Virscherm_actief(0);
      Freemem(schermptr, sizeof(schermType));
    end;

    begin
    end.

[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]