// ====================================================================
// Mystic BBS Software               Copyright 1997-2013 By James Coyle
// ====================================================================
//
// This file is part of Mystic BBS.
//
// Mystic BBS is free software: you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation, either version 3 of the License, or
// (at your option) any later version.
//
// Mystic BBS is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with Mystic BBS.  If not, see <http://www.gnu.org/licenses/>.
//
// ====================================================================
// Comment test

/*
  Comment test! /* comments */ (* comments *)
  // more comments

*/

(*
  comment test  (* embedded comments *) /* embedded comments */
  // more comments
*)

procedure testcase;
var
  number : longint;
  num2   : longint;
  num3   : longint;
  num4   : real;
  ch1    : char;
  str1   : string[20];
begin
  write ('Testing CASE statement... ')

  number := 73;
  num2   := 13;
  num3   := -1;
  num4   := 12.12;
  ch1    := 'A';
  str1   := 'hello';

  case number of
    68     : begin
               writeln('number is 68!');
             end
    69     : writeln('number is 69!');
    70, 71 : writeln('number is 70 or 71');
    72..80 : begin
               case num2 of
                 10 : writeln('num2 = 10');
                 11 : begin
                        writeln('num2 = 11');
                      end;
                 13 : case num3 of
                       -1: begin
                             case num4 of
                               12.12: begin
                                        case ch1 of
                                          'A' : case str1 of
                                                  'hello' : writeln('PASSED');
                                                end;
                                        end;
                                      end;
                             end;
                           end;
                      end;
               else
                 writeln('num2 is something else');
               end;
             end;
  else
    writeln('number is not found!');
  end;
end;

procedure testnumbers;
var
  num1,
  num2 : longint;
  num3 : array[1..10] of byte;
  num4 : array[1..10, 1..10, 1..10] of byte;
  num5 : longint;
begin
  write ('Testing NUMBERS... ');

  num1        := 2 + 12 * 2;
  num2        := -10;
  num3[1]     := 50;
  num4[1,1,1] := (6 - 1) + 5 * 4;
  num5        := 10 % 2 ^ 3;       // 2 to 3rd is 8, 10 modulus 8 = 2

  // floating point, mods, powers, PEDMAS, etc...

  if (num2 = -10) and (num1 = 26) and (num2 = -10) and (num3[1] = 50) and
     (num4[1,1,1] = 25) and (num5 = 2) then
    writeln('PASSED')
  else
    writeln('FAILED');
end;

procedure testrecords;
type
  testrec = record                 // total 502 bytes:
    x : byte;
    y : byte;
    d : array[1..10,1..5] of string[9];
  end;

var
  test   : array[1..2] of testrec;
  test1  : testrec;
  test2  : testrec;
  passed : boolean = false;

begin
  Write ('Testing RECORDS... ');

  test[1].d[10,5] := 'test1';
  test[2].x       := 1;
  test[2].y       := 2;
  test[2].d[1,1]  := 'hi';
  test[2].d[2,1]  := 'hello'

  if (test[1].d[10,5][1] = 't') and (test[2].x = 1) and (test[2].y = 2) and
     (test[2].d[1,1] = 'hi') and (test[2].d[2,1] = 'hello') then
       passed := true;

  if passed then begin
    test1.x      := 1;
    test1.y      := 2;
    test1.d[1,1] := 'hi';
    test1.d[2,1] := 'hello';

    test2   := test1;
    test[1] := test2;

    passed := (test1.x = test2.x) and (test1.y = test2.y) and
              (test1.d[1,1] = test2.d[1,1]) and (test1.d[2,1] = test2.d[2,1]) and
              (test[1].x = test2.x) and (test[1].y = test2.y);
  end;

  if passed then
    writeln ('PASSED')
  else
    writeln ('FAILED');

end;

procedure testprocedures;

  procedure testproc1;

    procedure testproc2
    begin
      WriteLn ('PASSED')
    end;

  begin
    testproc2
  end;

begin
  Write ('Testing PROCEDURES... ');
  testproc1;
end;

procedure testrecursive (loop:byte)
begin
  If loop = 255 then
    write('Testing RECURSIVE...');

  loop := loop - 1;

  if loop > 1 then
    testrecursive(loop)
  else
    writeln('PASSED')
end;

procedure testfunctions;

  function testfunc1 (p1,p2:byte; p3:string) : byte;
  begin
    if (p1 <> 10) or (p2 <> 5) or (p3 <> 'hello') then
      testfunc1 := 5
    else
      testfunc1 := 10;
  end;

{$syntax iplc}
  func testfunc2 : string {
    testfunc2 = "ok"
  }

{$syntax pascal}

begin
  Write ('Testing FUNCTIONS... ');

  if (testfunc1(10, 5, 'hello') = 10) and (testfunc2 = 'ok') then
    writeln ('PASSED')
  else
    writeln ('FAILED')
end;

procedure testvarpassing;

  procedure testit (var str: string);
  begin
    str := str + ' world';
  end;

var
  str : string;
begin
  write ('Testing VARPASSING... ');
  str := 'hello';
  testit(str);
  if str = 'hello world' then
    writeln ('PASSED')
  else
    writeln ('FAILED');
end;

procedure teststringindex;
var
  str : string;
begin
  write ('Testing STRING IDX...');
  str := 'hello world';
  str[6] := #33;
  if (str[1] = str[1]) and (str[2] = #101) and (str[6] = '!') then
    writeln ('PASSED')
  else
    writeln ('FAILED')
end;

procedure testloops;
var
  count1 : byte;
  count2 : byte;
  count3 : byte;
  count4 : byte;
  count5 : byte;
  loop1  : byte;
  loop2  : byte;
begin
 Write ('Testing LOOPS...');

 count1 := 0;

 while count1 < 100 do begin
   count1 := count1 + 1;
   if count1 < 5 then continue;
   if count1 < 5 then writeln('FAIL');
   if count1 = 10 then break;
 end;

 count2 := 0;

 repeat
  count2 := count2 + 1;
  if count2 < 5 then continue;
  if count2 < 5 then writeln('FAIL');
  if count2 = 10 then break;
 until count2 = 100;

 for count3 := 1 to 100 do begin
   if count3 < 5 then continue;
   if count3 < 5 then writeln('FAIL');
   if count3 = 10 then break;
 end;

 loop1 := 0;

 for count4 := 1 to 10 do begin
   count4 := 10;
   loop1  := loop1 + 1;
 end;

 loop2 := 0;

 for count5 := 10 downto 1 do begin
   count5 := 1;
   loop2  := loop2 + 1;
 end;

 if (count1 = 10) and (count2 = 10) and (count3 = 10) and (count4 = 10) and
    (loop1 = 1) and (count5 = 1) and (loop2 = 1) then
   writeln ('PASSED')
 else
   writeln ('FAILED');
end;

procedure testconsts;
const
  const1 = 'hello';
  const2 = true;
  const3 = 555;
  const4 = 'A';
var
  str1 : string;
  bol1 : boolean;
  ch1  : char;
  num1 : longint;
  ok1  : boolean;
  ok2  : boolean;
  ok3  : boolean;
  ok4  : boolean;
begin
  write ('Testing CONSTS...');

  ok1  := false;
  ok2  := false;
  ok3  := false;
  ok4  := false;

  str1 := 'hello';
  bol1 := true;
  num1 := 555;
  ch1  := 'A'

  case str1 of
    const1 : ok1 := true;
  end;

  case bol1 of
    const2 : ok2 := true;
  end;

  case num1 of
    const3 : ok3 := true;
  end;

  case ch1 of
    const4 : ok4 := true;
  end;

  if ok1 and ok2 and ok3 and ok4 then
    writeln ('PASSED')
  else
    writeln ('FAILED')
end;

procedure testsyntaxparsing;

{$syntax iplc}  // Iniquity-like syntax for the oldskool or maybe C-heads
                // been thinking about moving it to be closer to javascript
                // than IPL?

  proc testiplc {
    @ byte test1, test2, test3 = 10;
    write ("PASS");
    @ string anywhere = "we can do this wherever..."
  }

{$syntax pascal}

  procedure testpascal;
  var
    test1, test2, test3 : byte = 10;  // not a pascal standard!
  begin
    writeln('ED');
    var anywhere : string = 'wait!  pascal doesn''t allow this!';
  end;

begin
  write ('Testing SYNTAX... ');
  testiplc;
  testpascal;
end;

procedure testfileio;
const
  fmReadWriteDenyNone = 66;
var
  f : file;
  b : array[1..11] of Char;
  s : string[20];
  l : longint;
begin
  write ('Testing FILEIO... ');

  // file IO is completely random.  no text/file crap like in pascal
  // but it operates very close to pascal, just easier.  splitting the
  // fOpen into fassign/frewrite/freset allows us to not have to open
  // and close files constantly to reset or recreate it as in MPL 1.
  // And doing away with raw numbers and adding a File type makes things
  // much more manageable (and gives us virtually unlimited files)

  fassign  (f, 'testmps.dat', fmReadWriteDenyNone);
  frewrite (f);
  fwriteln (f, 'Hello world');

  freset   (f);
  fread    (f, b[1], 11);

  freset   (f);
  freadln  (f, s);

  freset   (f);
  fseek    (f, fsize(f));

  if not feof(f) or fpos(f) <> fsize(f) then begin
    writeln('FAILED');
    fclose(f);
    exit;
  end;

  fclose (f);

  if fileexist('testmps.dat') then fileerase('testmps.dat');

  if ioresult <> 0 or fileexist('testmps.dat') then begin
    writeln('FAILED');
    exit;
  end;

  // we can read data directly in to char arrays or strings as if it were
  // a char array.  no problems with reading non-pascal structs.

  if b[1] = 'H' and b[2] = 'e' and b[3] = 'l' and s = 'Hello world' then
    writeln('PASSED')
  else
    writeln('FAILED');
end;

procedure testrecordfileIO;
type
  myuserrecord = record
    username  : string[30];
    somevalue : array[1..5] of byte;
  end;

var
  f : file;
  u : myuserrecord;
  a : byte;
begin
  Write ('Testing RECORDFILEIO... ');

  u.username := 'testuser';

  for a := 1 to 5 do
    u.somevalue[a] := 1;

  fassign   (f, 'testmps.dat', 66);
  frewrite  (f);
  fwriterec (f, u);

  fillchar(u, sizeof(u), #0);

  freset   (f);
  freadrec (f, u);
  fclose   (f);

  if fileexist('testmps.dat') then fileerase('testmps.dat');

  if (u.username = 'testuser') and (u.somevalue[1] = 1) and (u.somevalue[2] = 1) and
     (u.somevalue[3] = 1) and (u.somevalue[4] = 1) and (u.somevalue[5] = 1) then
       writeln('PASSED')
  else
       writeln('FAILED');
end;

begin
  writeln ('|07|16|CLMystic BBS Programming Language Test Module');
  writeln ('');

  testcase;
  testnumbers;
  testrecords;
  testprocedures;
  testfunctions;
  testrecursive(255);
  testvarpassing;
  teststringindex;
  testloops;
  testconsts;
  testsyntaxparsing;
  testfileio;
  testrecordfileio;

  writeln('|CRAll tests complete.  Press a key.|PN');
end