Gammon Forum

(* Sine Wave plotting program
By Steve Smit  Oct 2015
Written in G-Pascal *)
const   bitmap = 1;
        base = 8;
        black = 0;
        yellow = 7;
        on = 1;
var     x, y, p, n : integer ;

function sin (x);
begin 
  sin := 4 * x * (180 - x) * 100 / ( 40500 - x * (180 - x))
end ;

(* main program *)
begin 
writeln (chr (147),"Sine Wave Programe by Steve Smit");
writeln ;
writeln ("press enter when ready");
repeat until getkey ;
graphics (bitmap,on);
graphics (8,4);
clear (yellow,black);
for x := 0 to 319 do 
begin 
p := x;
n := 0;
    if x > 180 then 
      begin 
      n := 1;
      p := x - 180;
      end ;
    y := sin (p);
    if y > 99 then y := 99;
    if n = 1 then y := - y;
    plot (1, x, 100-y);
    end ;
repeat until getkey ;
end .

(* open PCTEXT file and load into memory *)

(* %a $810 *)

const 
  CR = 13;
  start_ad = $4000;

var 
  i : integer ;
  TEXT_LINE : array [82] of char ;
  GOTCH, x : char ;

function eof;
  begin 
    eof := memc [$90] and $40 <> 0
  end ;

(* start of main program *)

begin 
  i := start_ad;
  writeln (chr (147),"PCTEXT to G-Pascal program");
  writeln ("On success, the read program will be in");
  writeln ("memory for listing and saving as a new");
  writeln ("G-Pascal program.");
  writeln ("Written by Steve Smit 2015");
  open (5,8,5,"0:pctext,p,r");
  get (5);
  repeat 
    read (TEXT_LINE);
    GOTCH := -1;
    while TEXT_LINE [GOTCH] <> cr do 
      begin 
      GOTCH := GOTCH + 1;
      x := TEXT_LINE [GOTCH];
      if (x > 64) and ((x and $5f) < 91) then 
        x := x xor $20; (* swap upper/lower case *)
      if x <> 10 then 
        begin 
        write (chr (x));
        memc [i] := x;
        i := i + 1
        end ;
      end 
  until eof;
  memc [i] := 13;
  memc [i + 1] := 0;
  get (0);
  close (5)
end .

(* program to save a g-pascal file

   as a PC text file called pctext

Author: Steve Smit

Using code from 'Centronics Print'

Written by: Nick Gammon of Gambit Games

Public Domain.


%a $800  *)

const 
      disk = 8;
      cassette = 1;
      medium = disk;

      strobereg = $dd00;  (* strobe register *)
      ddra = $dd02; (* data direction registers *)
      ddrb = $dd03;
      start_address = $4000;
      true = 1;
      false = 0;
      cr = 13;

var reprint,
    screen_only : integer ;

procedure init;
(*************)
const home = 147;

procedure load_nominated_file;
(****************************)

var 
    i,
    got_cr,
    error,
    length : integer ;
    name1, name2 : array [20]
                   of char ;

procedure get_file_name;
(**********************)
begin 
repeat 
  writeln ;
  write ("File name? ");
  read (name1);
  got_cr := false;
  for i := 0 to 20 do 
  if not got_cr then 
    begin 
    name2 [20 - i] := name1 [i];
    if name1 [i] = cr then 
      begin 
      length := i;
      got_cr := true;
      end 
    end 
until length <> 0
end ;

procedure load_file;
(******************)
const 
     areg = $2b2;
     xreg = $2b3;
     yreg = $2b4;
     cc = $2b1;
     loadit = $ffd5;
     setlfs = $ffba;
     setnam = $ffbd;
     readst = $ffb7;

begin 
  memc [areg] := 1;
  memc [xreg] := medium;
  memc [yreg] := 0; (* relocate *)
  call (setlfs);
  memc [areg] := length;
  memc [xreg] := address (name2[20]);
  memc [yreg] := address (name2[20]) shr 8;
  call (setnam);
  memc [areg] := 0; (* load *)
  memc [xreg] := start_address;
  memc [yreg] := start_address shr 8;
  call (loadit);
  if memc [cc] and 1 then 
    error := memc [areg]  (* got error *)
  else 
    begin 
    call (readst);
    error := memc [areg] and $bf
    end ;
  writeln ; writeln ;
  if error then 
    writeln ("Load error, code: ",
           error)
  else 
    writeln ("Loaded ok.")
end ;

(***** start of : load_nominated_file ***)
begin 
repeat 
  get_file_name;
  load_file
until not error
end ;

procedure open_pctext;
(*********************)
begin 
  open (5,8,2,"0:pctext,s,w")
end ;


function yes_no;
(**************)
var reply : char ;
begin 
  repeat 
    read (reply)
  until (reply = "y")
     or (reply = "n");
  writeln (chr (reply));
  writeln ;
  yes_no := reply = "y"
end ;

(****** start: init ***********)

begin 
  writeln (chr (home),
    "Convert G-Pascal PRG files to PCTEXT");
  writeln ;
    load_nominated_file;
    open_pctext
end ;

procedure print_file;
(*******************)
var 
   line,
   pointer,
   limit,
   count : integer ;
   ch : char ;

procedure next_char;
(*****************)
begin 
  ch := memc [pointer];
  pointer := pointer + 1
end ;

procedure print_char (x);
(**********************)
begin 
  write (chr (x));  (* echo on screen *)
  if not screen_only then 
    begin 
    (* convert x to ASCII *)
    if x >= 192 then 
      x := x and $7f
    else 
      if (x > 64) and ((x and $5f) < 91) then 
        x := x xor $20;  (* swap upper/lower case *)
    (* send data to pctext file *)
    put (5);
    write (chr (x));
    put (0)
    end 
end ;

procedure print_reserved_word (x);
(********************************)
const table = $81b5;
var position,
    length
    : integer ;

begin 
position := table;
while (memc [position + 1] <> x)
  and (memc [position] <> 0) do 
  position := position +
              memc [position] + 2;
if memc [position + 1] <> x then 
  print_char (x)
else 
  begin 
  length := memc [position];
  repeat 
    print_char (memc [position + 2]);
    position := position + 1;
    length := length - 1
  until length <= 0;
  print_char (" ")
  end 
end ;

procedure print_line;
(*******************)
var i,
    leading_zero : integer ;

procedure print_power (which);
(****************************)
begin 
  if (i / which > 0)
  or not leading_zero then 
    begin 
    leading_zero := false;
    print_char (i / which + "0")
    end 
  else 
    print_char (" ");
  i := i - line / which * which
end ;

(****** start: print_line ******)
begin 
  line := line + 1;
  i := line;
  leading_zero := true;
  print_power (1000);
  print_power (100);
  print_power (10);
  print_char (line mod 10 + "0");
  print_char (":");
  print_char (" ")
end ;

(******* start: print_file *******)
begin 
  pointer := start_address;
  line := 0;
  print_line;
  next_char;  (* get first character *)
  if ch <> 0 then  (* not blank file *)
  repeat 
    if ch = $10 then (* space count *)
      begin 
      next_char;
      limit := ch and $7f;
      for count := 1 to limit do 
        print_char (" ")
      end 
    else 
      if ch > $80 then 
        print_reserved_word (ch)
      else 
        print_char (ch);
    if ch = cr then 
      print_line;
    next_char  (* next character if any *)
until ch = 0
end ;

procedure wrap_up;
(***************)
begin 
  close (5);
  writeln ("File pctext write complete!")
end ;

(****** program starts here ******)
begin 
  init;
  print_file;
  wrap_up
end .