unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, StdCtrls, ComCtrls, ExtCtrls;

type
  VarAdr = Array [1..2] of Cardinal;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Code1: TMenuItem;
    View1: TMenuItem;
    Edit1: TMenuItem;
    About1: TMenuItem;
    Open1: TMenuItem;
    Save1: TMenuItem;
    Saveas1: TMenuItem;
    New1: TMenuItem;
    Exit1: TMenuItem;
    Copy1: TMenuItem;
    Cut1: TMenuItem;
    Paste1: TMenuItem;
    Undo1: TMenuItem;
    Execute1: TMenuItem;
    RuntoCursor1: TMenuItem;
    erminateExecution1: TMenuItem;
    ShowOutputPane1: TMenuItem;
    ShowInputPane1: TMenuItem;
    ShowCommandList1: TMenuItem;
    SetCodeFont1: TMenuItem;
    SetOutputFont1: TMenuItem;
    SetInputFony1: TMenuItem;
    SetOutputBuffer1: TMenuItem;
    ShowCommandPointer1: TMenuItem;
    Doneby1: TMenuItem;
    slilClingman1: TMenuItem;
    akaHATO1: TMenuItem;
    C2007TslilClingmanakaHATO1: TMenuItem;
    lbxC: TListBox;
    redC: TRichEdit;
    redO: TRichEdit;
    lbxL: TListBox;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    FontDialog1: TFontDialog;
    redI: TRichEdit;
    Interpreterwrittenby1: TMenuItem;
    slilClingmanakaHATO1: TMenuItem;
    procedure ShowOutputPane1Click(Sender: TObject);
    procedure ShowCommandList1Click(Sender: TObject);
    procedure ShowInputPane1Click(Sender: TObject);
    procedure redCChange(Sender: TObject);
    procedure Copy1Click(Sender: TObject);
    procedure Cut1Click(Sender: TObject);
    procedure Paste1Click(Sender: TObject);
    procedure Undo1Click(Sender: TObject);
    procedure SetCodeFont1Click(Sender: TObject);
    procedure SetOutputFont1Click(Sender: TObject);
    procedure SetInputFony1Click(Sender: TObject);
    procedure Save1Click(Sender: TObject);
    procedure Saveas1Click(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure New1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure SetOutputBuffer1Click(Sender: TObject);
    procedure erminateExecution1Click(Sender: TObject);
    procedure RuntoCursor1Click(Sender: TObject);
    procedure Execute1Click(Sender: TObject);
    procedure ShowCommandPointer1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  VarArr : Array [0..25] of Array [0..999] of Integer;
  DFDir,OutBuff  : String;
  MWS,Stop,ShowCP : Boolean;
  OBS,CBS,InPo : Cardinal;

implementation

{$R *.dfm}

procedure Output (outp : Integer; ASCII,OverrideB : Boolean);
begin
  if ASCII then begin OutBuff := OutBuff + Char(outp); inc(CBS); end
  else begin OutBuff := OutBuff + IntToStr(outp); inc(cbs); end;
  if (CBS>=OBS) or (OverrideB) then begin
    Form1.redO.Text := form1.redO.Text + OutBuff;
    CBS := 0;
    OutBuff := '';
  end;
  if (OverrideB) and (CBS<OBS) then begin Form1.redO.Text := form1.redO.Text + OutBuff; OutBuff := ''; CBS := 0; end;
end;

function Input () : Byte;
begin
  Result := Ord(form1.redI.Text[InPo]);
  inc(InPo);
end;

function GetArrayNum (inp : String) : VarAdr;
var l,n,k,p,q,r : Cardinal;

begin

  if inp[1]='$' then begin
    k := Ord(inp[2])- 97;
    q := 3;
    while inp[q] in ['0'..'9'] do inc(q);
    p := StrToInt(copy(inp,3,q-3));
    l := VarArr[k,p]-97;
  end else begin l := Ord(inp[1])-97; q := 2; end;

  if inp[q]='$' then begin
    inc(q,2);
    k := Ord(inp[q-1])-97;
    r := q;
    while inp[q] in ['0'..'9'] do inc(q);
    p := StrToInt(Copy(inp,r,q-r));
    n := VarArr[k,p];
  end else begin
    r := q;
    while inp[q] in ['0'..'9'] do inc(q);
    n := StrToInt(Copy(inp,r,q-r));
  end;

  result[1]:=l;
  result[2]:=n;

end;

procedure Interpret(code : String; ut : Int64);
var k,p,n,n2 : Integer; CP : Integer; CPD : Boolean; ta,tat : VarAdr;

  procedure IncreaseCP ();
  begin
    if CPD then inc(CP) else dec(CP);
    while CP>6 do dec(CP,7);
    while CP<0 do inc(CP,7);
  end;

begin
  k := 1;
  CP := 0;
  CPD := true;
  InPo := 1;

  for p := 0 to 25 do for n := 0 to 999 do VarArr[p,n] := 0;

  while k<=ut do begin

    case code[k] of
    '@' : begin CP := 0; CPD := true; end;
    '~' : CPD := not CPD;
    '{' : begin
            p := k;
            while code[p]<>'}' do inc(p);
            if CPD then CP := CP + StrToInt(Copy(code,k+1,p-k-1))
            else CP := CP - StrToInt(Copy(code,k+1,p-k-1));
            while CP>6 do dec(CP,7);
            while CP<0 do inc(CP,7);
            k := p;
          end;
    '[' : begin
            case CP of
              0..1 : begin
                      p := k;
                      while code[p]<>']' do inc(p);
                      ta := GetArrayNum(Copy(code,k+1,p-k-1));
                      if CP=0 then inc(VarArr[ta[1],ta[2]])
                      else dec(VarArr[ta[1],ta[2]]);
                      k := p;
                      IncreaseCP;
                     end;

              2    : begin
                      if code[k+1]='!' then begin
                        if (code[k+3] in ['a'..'z']) or (code[k+3]='$') then begin
                          p := k+3;
                          while code[p]<>']' do inc(p);
                          ta := GetArrayNum(Copy(Code,k+3,p-k-3));
                          n := VarArr[ta[1],ta[2]];
                        end else begin
                          p := k+3;
                          while code[p]<>']' do inc(p);
                          n := StrToInt(Copy(code,k+3,p-k-3));
                        end;
                        if code[k+2]='+' then begin
                          k := p;
                          p := 0;
                          while n>0 do begin
                            inc(k);
                            if code[k] in ['{','@','~'] then dec(n);
                            if code[k]='[' then p := 1;
                            if (code[k]=']') and (p=1) then begin dec(n); dec(p); end;
                          end;
                          if code[k]='{' then while code[k]<>'}' do inc(k)
                          else if code[k]='[' then begin
                            p:= 1;
                            n := 1;
                            while n>0 do begin
                              inc(k);
                              if code[k]='[' then p := 1;
                              if (code[k]=']') and (p=1) then begin dec(n); dec(p); end;
                            end;
                          end;
                        end
                        else begin
                          p := 0;
                          while n>0 do begin
                            dec(k);
                            if code[k] in ['}','@','~'] then dec(n);
                            if code[k]=']' then p := 1;
                            if (code[k]='[') and (p=1) then begin dec(n); dec(p); end;
                          end;
                          if code[k]='[' then begin
                            p:= 1;
                            n := 1;
                            while n>0 do begin
                              inc(k);
                              if code[k]='[' then p := 1;
                              if (code[k]=']') and (p=1) then begin dec(n); dec(p); end;
                            end;
                          end;
                        end;
                      end
                      else begin
                        if (code[k+1]='$') or (code[k+1] in ['a'..'z']) then begin
                          p := k+1;
                          while code[p]<>']' do inc(p);
                          ta := GetArrayNum(Copy(code,k+1,p-k-1));
                          n := VarArr[ta[1],ta[2]];
                        end else begin
                          p := k+1;
                          while code[p]<>']' do inc(p);
                          n := StrToInt(copy(code,k+1,p-k-1));
                        end;
                        k := 0;
                        if n>0 then begin
                          p := 0;
                          while n>0 do begin
                            inc(k);
                            if code[k] in ['{','@','~'] then dec(n);
                            if code[k]='[' then p := 1;
                            if (code[k]=']') and (p=1) then begin dec(n); dec(p); end;
                          end;
                           if code[k]='{' then while code[k]<>'}' do inc(k)
                          else if code[k]='[' then begin
                            p:= 1;
                            n := 1;
                            while n>0 do begin
                              inc(k);
                              if code[k]='[' then p := 1;
                              if (code[k]=']') and (p=1) then begin dec(n); dec(p); end;
                            end;
                          end;
                        end;
                      end;
                      IncreaseCP;
                     end;

              3    : begin
                        if code[k+1]='#' then begin
                          p := k+1;
                          while code[p]<>']' do inc(p);
                          ta := GetArrayNum(Copy(code,k+2,p-k-2));
                          Output(VarArr[ta[1],ta[2]],false,false);
                        end else begin
                          p := k+1;
                          while code[p]<>']' do inc(p);
                          ta := GetArrayNum(Copy(code,k+1,p-k-1));
                          Output(VarArr[ta[1],ta[2]],true,false);
                        end;
                        k := p;
                        IncreaseCP;
                     end;

              4    : begin
                      p := k+1;
                      while code[p]<>']' do inc(p);
                      ta := GetArrayNum((Copy(code,k+1,p-k-1)));
                      VarArr[ta[1],ta[2]] := Input;
                      k := p;
                      IncreaseCP;
                     end;

              5    : begin
                      inc(k,2);
                      p := k;
                      while not (code[p] in ['=','>','/']) do inc(p);

                      if (code[k] in ['a'..'z']) or (code[k] = '$') then begin ta := GetArrayNum(Copy(code,k,p-k)); n := VarArr[ta[1],ta[2]]; end;
                      if code[k]='?' then n := Ord(code[k+1]);
                      if code[k] in ['0'..'9'] then n := StrToInt(Copy(code,k,p-k));
                      if code[p]='/' then k := p+1 else k := p;
                      n2 := k+1;
                      while code[n2]<>')' do inc(n2);
                      if (code[k+1] in ['a'..'z']) or (code[k+1] = '$') then begin ta := GetArrayNum(Copy(code,k+1,n2-k-1)); n2 := VarArr[ta[1],ta[2]]; end;
                      if code[k+1]='?' then n2 := Ord(code[k+2]);
                      if code[k+1] in ['-','0'..'9'] then n2 := StrToInt(Copy(code,k+1,n2-k-1));

                      if  ((n<>n2) and (copy(code,p,k-p+1)='=')) or
                          ((n<=n2) and (copy(code,p,k-p+1)='>')) or
                          ((n=n2) and (copy(code,p,k-p+1)='/=')) or
                          ((n>n2) and (copy(code,p,k-p+1)='/>'))
                      then begin
                        while (code[k]<>')') and (code[k+1]<>'(') do inc(k);
                        inc(k);
                        n := 1;
                        while n>0 do begin
                          inc(k);
                          if code[k]='(' then inc(n);
                          if code[k]=')' then dec(n);
                        end;
                        inc(k);
                        IncreaseCP;
                      end else while code[k]<>'(' do inc(k);
                     end;

              6    : begin
                      inc(k,2);
                      p := k; while code[p]<>')' do inc(p);
                      ta := GetArrayNum(Copy(code,k,p-k));
                      k := p+2;
                      p := k;
                      while code[p]<>')' do inc(p);
                      if (code[k] in ['a'..'z']) or (code[k]='$') then begin
                        tat := GetArrayNum(Copy(code,k,p-k));
                        VarArr[ta[1],ta[2]] := VarArr[tat[1],tat[2]];
                        while code[k]<>']' do inc(k);
                      end;
                      if code[k]='?' then begin
                        VarArr[ta[1],ta[2]] := Ord(code[k+1]);
                        while code[k]<>']' do inc(k);
                      end;
                      if code[k] in ['-','0'..'9'] then begin
                        VarArr[ta[1],ta[2]] := StrToInt(Copy(code,k,p-k));
                        while code[k]<>']' do inc(k);
                      end;
                      IncreaseCP;
                     end;
            end;
          end;
    end;
    inc(k);
    Application.ProcessMessages;
    if stop then exit;
    if ShowCP then begin form1.lbxC.ItemIndex := CP; sleep(250); end;
  end;
  Output(0,True,True);
end;

procedure Save (sas : Boolean);
begin
  with form1 do begin
    if not sas then if DFDir='' then if SaveDialog1.Execute() then DFDir := SaveDialog1.FileName;
    if sas then if SaveDialog1.Execute() then DFDir := SaveDialog1.FileName;
    if dfdir<>'' then begin
      if pos('.f0',DFDir)=0 then DFDir := DFDir+'.f0';
      redC.Lines.SaveToFile(DFDir);
      mws := false;
    end;
  end;
end;

procedure TForm1.Copy1Click(Sender: TObject);
begin
redC.CopyToClipboard;
end;

procedure TForm1.Cut1Click(Sender: TObject);
begin
redC.CutToClipboard;
end;

procedure TForm1.erminateExecution1Click(Sender: TObject);
begin
Stop := true;
erminateExecution1.Enabled := false;
Execute1.Enabled := true;
RuntoCursor1.Enabled := true;
form1.Caption := 'Full 0 Interpreter - (C) 2007 Tslil Clingman, aka H!ATO';
end;

procedure TForm1.Execute1Click(Sender: TObject);
begin
form1.Caption := 'Full 0 Interpreter - Working - (C) 2007 Tslil Clingman, aka H!ATO';
RedO.Clear;
stop := false;
erminateExecution1.Enabled := true;
Execute1.Enabled := false;
RuntoCursor1.Enabled := false;
Interpret(redC.Text,length(redC.Text));
Execute1.Enabled := true;
RuntoCursor1.Enabled := true;
erminateExecution1.Enabled := false;
Execute1.Enabled := true;
form1.Caption := 'Full 0 Interpreter - (C) 2007 Tslil Clingman, aka H!ATO';
end;

procedure TForm1.Exit1Click(Sender: TObject);
var k : Byte;
begin
if mws then begin
  k := MessageDlg('Are you positive that you want to discard changes to the current file?',mtConfirmation,mbYesNo,0);
  if k=7 then Save(true);
end;
form1.Close;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
InPo := 1;
OBS := 8;
end;

procedure TForm1.New1Click(Sender: TObject);
var k : Byte;
begin
if mws then begin
  k := MessageDlg('Are you positive that you want to discard changes to the current file?',mtConfirmation,mbYesNo,0);
  if k=7 then Save(true);
end;
DFDir := '';
redC.Clear;
redI.Clear;
redO.Clear;
end;

procedure TForm1.Open1Click(Sender: TObject);
var k : Byte;
begin
if mws then begin
  k := MessageDlg('Are you positive that you want to discard changes to the current file?',mtConfirmation,mbYesNo,0);
  if k=7 then Save(true);
end;
if OpenDialog1.Execute() then redC.Lines.LoadFromFile(OpenDialog1.FileName);
end;

procedure TForm1.Paste1Click(Sender: TObject);
begin
redC.PasteFromClipboard;
end;

procedure TForm1.redCChange(Sender: TObject);
var k : Cardinal;
begin
if (lbxL.Items.Count<>redC.Lines.Count) and (redC.Lines.Count-1>=0) then begin
  lbxL.Clear;
  for k := 0 to redC.Lines.Count-1 do lbxL.Items.Add(IntToStr(k+1));
end;
if redC.Lines.Count-1<0 then lbxL.Clear;
MWS := true;
end;

procedure TForm1.RuntoCursor1Click(Sender: TObject);
begin
form1.Caption := 'Full 0 Interpreter - Working - (C) 2007 Tslil Clingman, aka H!ATO';
redO.Clear;
stop := false;
erminateExecution1.Enabled := true;
Execute1.Enabled := false;
RuntoCursor1.Enabled := false;
Interpret(redC.Text,redC.SelStart);
Execute1.Enabled := true;
RuntoCursor1.Enabled := true;
erminateExecution1.Enabled := false;
form1.Caption := 'Full 0 Interpreter - (C) 2007 Tslil Clingman, aka H!ATO';
end;

procedure TForm1.Save1Click(Sender: TObject);
begin
Save(false);
end;

procedure TForm1.Saveas1Click(Sender: TObject);
begin
Save(true);
end;

procedure TForm1.SetCodeFont1Click(Sender: TObject);
begin
if FontDialog1.Execute() then begin
  redC.Font := FontDialog1.Font;
  redC.Font.Style := FontDialog1.Font.Style;
  redC.Font.Color := FontDialog1.Font.Color;
  lbxL.Font := redC.Font;
end;
end;

procedure TForm1.SetInputFony1Click(Sender: TObject);
begin
if FontDialog1.Execute() then begin
  redI.Font := FontDialog1.Font;
  redI.Font.Style := FontDialog1.Font.Style;
  redI.Font.Color := FontDialog1.Font.Color;
end;
end;

procedure TForm1.SetOutputBuffer1Click(Sender: TObject);
var k : Cardinal; s,m : String;
begin
k := OBS;
m := 'The output buffer determines how many characters are stored in a buffer during programme runtime';
m := m + ' prior to their being displayed. This leads to more efficiant execution of output-heavy programmes.';
m := m + ' However, if it appears that the programme is not responding, or the output is appearing to late,';
m := m + ' simply decrease the buffer size. Use a value of 1 to display every character immediately. Please enter a natural number number now: ';
s := InputBox('Please select the new output buffer size',m,IntToStr(k));
try
  k := StrToInt(s);
except
  MessageDlg('Buffer size may only be an integer from 1 to 8192 (inclusive)',mtError,[mbOk],0);
end;
OBS := k;
end;

procedure TForm1.SetOutputFont1Click(Sender: TObject);
begin
if FontDialog1.Execute() then begin
  redO.Font := FontDialog1.Font;
  redO.Font.Style := FontDialog1.Font.Style;
  redO.Font.Color := FontDialog1.Font.Color;
end;
end;

procedure TForm1.ShowCommandList1Click(Sender: TObject);
begin
if ShowCommandList1.Checked then begin
  lbxC.Visible := false;
  lbxL.Left := lbxC.Left;
  redC.Left := redC.Left - lbxL.Width;
  redC.Width := redC.Width + lbxL.Width;
  redI.Left := redI.Left - lbxL.Width;
  redI.Width := redI.Width + lbxL.Width;
  ShowCommandList1.Checked := false;
end else begin
  lbxC.Visible := true;
  lbxC.Height := redC.Height;
  lbxL.Left := lbxL.Left + lbxC.Width;
  redC.Left := redC.Left + lbxL.Width;
  redC.Width := redC.Width - lbxL.Width;
  redI.Left := redI.Left + lbxL.Width;
  redI.Width := redI.Width - lbxL.Width;
  ShowCommandList1.Checked := true;
end;
end;

procedure TForm1.ShowCommandPointer1Click(Sender: TObject);
begin
if ShowCommandPointer1.Checked then begin
  showcp := false;
  if lbxC.Visible = true then ShowCommandList1.Click;
  ShowCommandPointer1.Checked := false;
end else begin
  showcp := true;
  if lbxC.Visible = false then ShowCommandList1.Click;
  ShowCommandPointer1.Checked := true;
end;
end;

procedure TForm1.ShowInputPane1Click(Sender: TObject);
begin
if ShowInputPane1.Checked then begin
  redI.Visible := false;
  ShowInputPane1.Checked := false;
  redC.SetFocus;
end else begin
  redI.Visible := true;
  ShowInputPane1.Checked := true;
  redI.SetFocus;
end;
end;

procedure TForm1.ShowOutputPane1Click(Sender: TObject);
begin
if ShowOutputPane1.Checked then begin
  redO.Visible := false;
  redC.Height := redC.Height + redO.Height;
  lbxL.Height := redC.Height;
  ShowOutputPane1.Checked := false;
end else begin
  redO.Visible := true;
  redC.Height := redC.Height - redO.Height;
  lbxL.Height := redC.Height;
  ShowOutputPane1.Checked := true;
end;
end;

procedure TForm1.Undo1Click(Sender: TObject);
begin
redC.Undo;
end;

end.