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

    {Jaco van Niekerk   sparky@lantic.co.za}
    {Any comments, whatever, please mail!}

    {Please note : I take NO responsibility on the effect of the code  }
    {              I've tested it on many machines, so I can't see any }
    {              reason why it should not work on yours.             }

    {worm hole in 320x200}
    {$N+}
    program wormhole;
    uses crt; {for keypressed}

    var circle_x : array[1..80, 0..61] of integer;
        circle_y : array[1..80, 0..61] of integer;
        cposx, xposy : array[1..80, 0..61] of integer;
        relpos_x : array[1..80] of integer;
        relpos_y : array[1..80] of integer;
        vscreen : pointer;

    procedure calc_circles;
    var deg, x, y, c : integer;
    begin
         for c:=1 to 80 do
         begin
              relpos_x[c]:=0; relpos_y[c]:=0;
              for deg:=0 to 60 do
              begin
                   x:=round(c*3*cos(deg*pi/30)); y:=round(c*3*sin(deg*pi/30));
                   circle_x[c, deg]:=160+x; circle_y[c, deg]:=100+y;
              end;
         end;
    end;

    procedure copyw(source : pointer; dest : pointer; cnt : word);assembler;
    asm
       les di, [dest]
       push ds
       lds si, [source]
       mov cx, [cnt]
       cld
       rep movsw
       pop ds
    end;

    procedure clrdw(source : pointer; cnt : word);assembler;
    asm
       les di, [source]
       mov cx, [cnt]
       db $66; xor ax, ax {xor eax, eax}
       db $66; rep stosw  {rep storsdw}
    end;

    procedure waitretrace;assembler;
    asm {this waits for a vertical retrace, exiting when it occurs}
       mov dx,3DAh
       @loop1:
       in al,dx
       and al,08h
       jnz @loop1
       @loop2:
       in al,dx
       and al,08h
       jz @loop2
    end;

    var xp, yp, i, j, sg, os, new_y, new_x : word;
        cx, cy, dx, dy : real;
        tx, ty : integer;

        mpos : integer;

    begin
         randomize;
         if maxavail<64000 then
            begin writeln('Not enough memory!'); halt(1); end;

         getmem(vscreen, 64000);

         calc_circles;
         sg:=seg(vscreen^); os:=ofs(vscreen^);
         cx:=0; cy:=0; dx:=0; dy:=0;
         tx:=random(20)-10; ty:=random(20)-10;
         asm mov ax, 13h; int 10h; end;

         port[$3c8]:=1;
         for i:=1 to 80 do
         begin
              port[$3c9]:=round(i*0.7);
              port[$3c9]:=round(i*0.7);
              port[$3c9]:=round(i*0.7);
         end;

         repeat
               {clear screen}
               clrdw(vscreen, 16000);

               {update offset buffer}
               for i:=80 downto 1 do
                   begin
                        relpos_x[i]:=relpos_x[i-1];
                        relpos_y[i]:=relpos_y[i-1];
                   end;

               {create "new" circle}
               if cx>tx then dx:=dx-0.55 else
                  if cx<tx then dx:=dx+0.55;
               if cy>ty then dy:=dy-0.55 else
                  if cy<ty then dy:=dy+0.55;
               if sqr(cx-tx)+sqr(cy-ty)<200 then
               begin tx:=random(80)-30; ty:=random(50)-25; end;
               cx:=cx+dx; cy:=cy+dy;

               {speed control}
               if dx>5 then dx:=5;
               if dx<-5 then dx:=-5;
               if dy>5 then dy:=5;
               if dy<-5 then dy:=-5;

               {update new circle}
               relpos_x[1]:=round(cx); relpos_y[1]:=round(cy);

               {plot circles}
               for i:=1 to 80 do
                   for j:=0 to 60 do
                   begin
                        new_x:=circle_x[i][j] + relpos_x[i];
                        new_y:=circle_y[i][j] + relpos_y[i];
                        if (new_x>0) and (new_x<320) and
                           (new_y>0) and (new_y<200) then
                           mem[sg:os+new_y shl 6+new_y shl 8+new_x]:=i;

                   end;

               {blast to screen}
               waitretrace;
               copyw(vscreen, ptr($a000,0000), 32000);
         until (keypressed);
         asm mov ax, 03h; int 10h; end;

         freemem(vscreen, 64000);
    end.
    --Message-Boundary-5639
    Content-type: text/plain; charset=US-ASCII
    Content-transfer-encoding: 7BIT
    Content-description: Text from file 'SIMBA.PAS'

    { By Jaco van Niekerk - sparky@lantic.co.za
       (Any problems, feel free to mail me)

    {Please note : I take NO responsibility on the effect of the code  }
    {              I've tested it on many machines, so I can't see any }
    {              reason why it should not work on yours.             }

    {The wonders of the VGA card}
    {$N+}
    program run_around;
    uses crt;

    type header = record
           manufacturer : byte;
           version : byte;
           encoding : byte;
           bits_per_pixel : byte;
           xmin, ymin, xmax, ymax : integer;
           hdpi, vdpi : integer;
           colormap : array[0..47] of byte;
           reserved : byte;
           nplanes : byte;
           bytes_per_line : integer;
           palette_info : integer;
           hscreensize, vscreensize : integer;
           dummy : array[0..53] of byte;
         end;

    const width : byte = 80; {80 * 8 = 640}
          fade = 20;
          spin = 200;

    procedure initmode; {320x200 chain4 off}
    begin
         {first go to chain-4 mode}
         asm
            mov ah, 0
            mov al, 13h
            int 10h
         end;
         {turn chain-4 bit off}
         port[$3c4]:=$4; {index 2}
         port[$3c5]:=port[$3c5] and $f7; {now set bit 3 to zero}
         {turn off word mode}
         port[$3d4]:=$17; {index 17}
         port[$3d5]:=port[$3d5] or $40;
         {turn off double word mode}
         port[$3d4]:=$14; {index 14}
         port[$3d5]:=0;
         {set logical screen width}
         port[$3d4]:=$13;
         port[$3d5]:=width;
         {clear the video memory}
         portw[$3c4]:=$0f02;
         fillchar(mem[$a000:000],65535,0);
    end;

    procedure moveto(x, y : word);
    var offset : word;
    begin
         offset:=width*2*y+(x div 4);
         port[$3d4]:=$c; port[$3d5]:=hi(offset);
         port[$3d4]:=$d; port[$3d5]:=lo(offset);
         {smooth panning compatible}
         port[$3c0]:=$13 or $20;
         port[$3c0]:=(x mod 4) shl 1;
    end;

    procedure putpixel(x, y : word; col : byte);assembler;
    asm
       mov ax, 0a000h
       mov es, ax           {video address in es}
       mov dx, 03c4h        {mov register value into dx}
       mov al, 02h          {we want index 2}
       mov ah, 01h          {from here on, calculate the correct plane}
       mov cx, [x]
       and cx, 3
       shl ah, cl
       out dx, ax           {one port write}
       mov ax, [y]          {calculate address}
       shl ax, 1
       shl ax, 4
       mov di, ax
       shl ax, 2
       add di, ax
       mov ax, [x]
       shr ax, 2
       add di, ax
       mov al, [col]
       mov [es:di], al      {plot the colour}
    end;

    function getpixel(x, y : word):byte;assembler;
    asm
       mov ax, 0a000h
       mov es, ax
       mov dx, $3ce         {prepare port word}
       mov bx, [x]
       and bx, 3
       mov ah, bl
       mov al, 04h
       out dx, ax           {write ax to port dx}
       mov ax, [y]          {calculate address}
       shl ax, 1
       shl ax, 4
       mov di, ax
       shl ax, 2
       add di, ax
       mov ax, [x]
       shr ax, 2
       add di, ax
       mov al, [es:di]      {get the colour}
    end;

    function pcxbackground(fname : string):boolean;
    {INPUT  : filename of 256 colour pcx image                       }
    {OUTPUT : TRUE if image load successful                          }
    {OTHER  : either loads pcx file or not, fades palette in         }
    const dskbufsize = 8192;
    var hdrb : header;
        palb : array[0..767] of byte;
    var {general vars}
        f : file;
        eb, dta, rle, ecode : byte;
        dx, dy, i, j  : word;
        tot, mc : longint;

        {global cashread vars}
        dskbuf : array[0..dskbufsize-1] of byte;
        cnt, cursize : word;

        function casheread : byte;
        begin {cashread routine}
             if cnt=cursize then {read ahead}
             begin
                  blockread(f, dskbuf, dskbufsize, cursize); cnt:=0;
             end;
             cnt:=cnt+1;
             casheread:=dskbuf[cnt-1];
        end;

    begin
         assign(f, fname);
         {$I-} reset(f, 1); {$I+} eb:=ioresult;
         if eb=0 then
         begin
              {set up globals}
              port[$3c8]:=0; for i:=0 to 767 do port[$3c9]:=0;
              cnt:=0; cursize:=0; ecode:=0;
              if filesize(f)<1920 then ecode:=3;
              if ecode=0 then
              begin
                   {pcx header}
                   blockread(f, hdrb, 128);

                   {256 colour palette}
                   seek(f, filesize(f)-768); blockread(f, palb, 768);
                   seek(f, 128); {actual data}
              end;

              {complete encoding test}
              with hdrb do
              begin
    		if manufacturer<>10 then ecode:=3;
    		if encoding<>1 then ecode:=3;
    		if bits_per_pixel<>8 then ecode:=3;
    		if nplanes<>1 then ecode:=3;
    	  end;
              if ecode<>3 then
              begin
                   {calc needy vars}
                   dx:=(hdrb.xmax-hdrb.xmin)+1; dy:=(hdrb.ymax-hdrb.ymin)+1;
                   tot:=longint(dx) * longint(dy);
                   mc:=0;

                   while (mc<tot) and (ecode=0) do
                   begin
                        dta:=casheread;
                        if (dta and $c0) = $c0 then
                        begin {run-length-encoding}
                             rle:=casheread; dta:=dta and $3f;
                             for i:=0 to dta-1 do
                                 putpixel((mc+i) mod dx, (mc+i) div dx, rle);
                             inc(mc, dta);
                        end else
                        begin {no compression}
                             putpixel(mc mod dx, mc div dx, dta);
                             inc(mc);
                        end;
                   end;
                   close(f);
                  { for j:=0 to 100 do
                   begin} j:=100;
                        port[$3c8]:=0;
                        for i:=0 to 767 do port[$3c9]:=round(palb[i]*j/100) div 4;
                  { end; }
                   pcxbackground:=true;
              end;
         end else pcxbackground:=false;
    end;

    procedure waitretrace;assembler;
    asm
       mov dx,3DAh
       @loop1:
       in al,dx
       and al,08h
       jnz @loop1
       @loop2:
       in al,dx
       and al,08h
       jz @loop2
    end;

    var i, j, k : word;
        x, y, deg, w : real;
        f : file;
        c : array[0..768] of real;

    begin
         initmode;
         {any 640x400 pcx file, 8bit}
         if pcxbackground('yourfile.pcx') then
         begin
              x:=0; y:=0; deg:=0;
              while keypressed do readkey;

              repeat
                    moveto(round(160+x), round(100+y));
                    x:=160*sin(deg*2)*cos(deg);
                    y:=100*sin(deg/2)*sin(deg);
                    deg:=deg+0.001;
              until keypressed;
         end;

         asm
            mov ah, 0
            mov al, 03h
            int 10h
         end;
    end.
    --Message-Boundary-5639
    Content-type: text/plain; charset=US-ASCII
    Content-transfer-encoding: 7BIT
    Content-description: Text from file 'RS232.PAS'

    { By Jaco van Niekerk - sparky@lantic.co.za
       (Any problems, feel free to mail me)

      Unit to handle RS232 communication
      Set the COM ports up with open_serial
      Shut down with close_serial
      recieve_byte and send_byte fot the communication }

    {Please note : I take NO responsibility on the effect of the code  }
    {              I've tested it on many machines, so I can't see any }
    {              reason why it should not work on yours.             }

    unit rs232;

    interface

    const COM_1 = $3f8;
          COM_2 = $2f8;

          SER_BAUD_600 = 192;
          SER_BAUD_1200 = 96;
          SER_BAUD_2400 = 48;
          SER_BAUD_9600 = 12;
          SER_BAUD_19200 = 6;
          SER_BAUD_115200 = 1;

          SER_STOP_1 = 0;
          SER_STOP_2 = 4;

          SER_BITS_5 = 0;
          SER_BITS_6 = 1;
          SER_BITS_7 = 2;
          SER_BITS_8 = 3;

          PARITY_NONE = 0;
          PARITY_ODD = 8;
          PARITY_EVEN = 24;

    var chars_waiting : integer;

    procedure open_serial(port_base, baud, configuration : word);
    procedure close_serial;

    function receive_byte:byte;
    procedure send_byte(thingy : byte);

    implementation
    uses dos;

    const Max_buffer_size = 8192;   {8kb circular buffer}

    {these variables CAN NOT be implemented as locals
    {and must therefore be declared global}

    var open_port : word;
        serial_lock : byte;
        old_int_mask : byte;
        old_handler : procedure;
        my_buffer : array[0..Max_buffer_size-1] of byte;
        buf_read, buf_write : integer;

    procedure my_handler;interrupt;
    var my_byte : byte;
    begin
         serial_lock:=1;                    {lock the buffer}
         my_byte:=port[open_port + 0];      {get byte from harware port}
         my_buffer[buf_write]:=my_byte;     {put byte into software buffer}

         buf_write:=(buf_write+1) mod Max_buffer_size;  {add + wrap around}
         inc(chars_waiting);                            {one more byte}

         port[$20]:=$20;          {let PIC know, we are done!}
         serial_lock:=0;          {unlock buffer}
    end;

    procedure close_serial;
    begin
         {disable required interrupts}
         port[open_port + 4]:=0;
         port[open_port + 1]:=0;
         port[$21]:=old_int_mask;

         {give controll back to old handler}
         if (open_port = COM_1) then setintvec($0c, addr(old_handler))
                                else setintvec($0b, addr(old_handler));
    end;

    procedure open_serial(port_base, baud, configuration : word);
    begin
         {set up global variables}
         open_port:=port_base;
         buf_read:=0; buf_write:=0;
         chars_waiting:=0;

         {set the baud rate}
         port[open_port + 3]:=128;
         port[open_port + 0]:=baud and 255; {lsb}
         port[open_port + 1]:=(baud shr 8) and 255; {msb}

         {set the configuration}
         port[open_port + 3]:=configuration;

         {setup interrupts and enable them}
         port[open_port + 4]:=8;               {enable interrupts}
         port[open_port + 1]:=1;               {interrupt CPU for char received}

         {now, take control!}
         if (open_port = COM_1) then
         begin
              getintvec($0c, @old_handler);
              setintvec($0c, addr(my_handler));
         end else
         begin
              getintvec($0b, @old_handler);
              setintvec($0b, addr(my_handler));
         end;

         {tell mr. PIC}
         old_int_mask:=port[$21];
         if (open_port = COM_1) then port[$21]:=old_int_mask and $ef
                                else port[$21]:=old_int_mask and $e7;
    end;

    function receive_byte:byte;
    var ret_this : byte;
    begin
         while (serial_lock = 1) do;
         if (chars_waiting>0) then
         begin
              ret_this:=my_buffer[buf_read];                {get next byte}
              buf_read:=(buf_read+1) mod Max_buffer_size;   {add + wrap around}
              dec(chars_waiting);                           {one less byte}
         end else ret_this:=0;
         receive_byte:=ret_this;
    end;

    procedure send_byte(thingy : byte);
    begin
         {pole line-status-register for "ready to send"}
         while not((port[open_port + 5] and $20)=$20) do {nothing};

         {interrupts has to be disbaled while sending is in progress}
         {unfortunatly this makes full-duplex communications not possible}
         asm cli end;
         port[open_port + 0]:=thingy;
         asm sti end;
    end;

    begin
    end.

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