Web walk generator

program MY_TSlackGUI;
{$I SRL/OSR.simba}
{$I SlackGUI/SlackGUI.simba}
{$H-}

type
  TWebGraph = record
    Nodes: TPointArray;
    Paths: T2DIntArray;
  end;

var
  // forms stuff
  WorldImg: TMufasaBitmap;
  CurrX, CurrY, tmpX, tmpY, StartX, StartY: Int32;
  IsDragging, IsDraggingNode, IsTesting: Boolean;

  // node stuff
  NodeCount: Int32;
  InFocus: Int32 = -1;
  Graph: TWebGraph;

  TestPath: TIntArray;


function ToString(X: TPoint): String; override;
begin
  Result := '['+ToString(X.X)+','+ToString(X.Y)+']';
end;

function ToString(X: TPointArray): String; override;
var i: Int32;
begin
  Result := '[';
  for i:=0 to High(X)-1 do Result += ToString(X[i])+',';
  Result += ToString(X[High(X)]);
  Result += ']';
end;

function LinesIntersect(p,q:array[0..1] of TPoint; out i:TPoint): Boolean;
var
  dx,dy,d: TPoint;
  dt,s,t: Double;
  function Det(a,b: TPoint): Int64;
  begin
    Result := a.x*b.y - a.y*b.x;
  end;
begin
  dx := [p[0].x - p[1].x, q[0].x - q[1].x];
  dy := [p[0].y - p[1].y, q[0].y - q[1].y];
  dt := det(dx, dy);
  if dt = 0 then Exit(False);
  d := [Det(p[0],p[1]), Det(q[0],q[1])];
  i.x := Round(Det(d, dx) / dt);
  i.y := Round(Det(d, dy) / dt);
  s := (dx.x * (q[0].y-p[0].y) + dy.x * (p[0].x-q[0].x)) / dt;
  t := (dx.y * (p[0].y-q[0].y) + dy.y * (q[0].x-p[0].x)) / (-dt);
  Result := (s > 0) and (s < 1) and (t > 0) and (t < 1);
end;

function CheckForNearbyNode(p: TPoint): Int32;
var i:Int32;
begin
  Result := -1;
  for i:=0 to High(Graph.Nodes) do
    if Distance(p,Graph.Nodes[i]) < 5 then
      Exit(i);
end;

function InvalidPath(p,q: TPoint): Boolean;
var
  i,n: Int32;
  l1,l2: array[0..1] of TPoint;
  _: TPoint;
begin
  l1 := [p,q];
  for i:=0 to High(Graph.Paths) do
  begin
    l2[0] := Graph.Nodes[i];
    for n in Graph.Paths[i] do
    begin
      l2[1] := Graph.Nodes[n];
      if (l1[0] = l2[0]) and (l1[1] = l2[1]) then
        Continue;
      if LinesIntersect(l1,l2,_) then
        Exit(True);
    end;
  end;
end;

procedure AddNode(p: TPoint);
var
  c: Int32;
begin
  if (InFocus <> -1) and (InvalidPath(p,Graph.Nodes[InFocus])) then
  begin
    WriteLn('Error: Path crosses another path');
    Exit;
  end;
  c := NodeCount;
  Inc(NodeCount);
  SetLength(Graph.Nodes, NodeCount);
  SetLength(Graph.Paths, NodeCount);

  Graph.Nodes[c] := p;
  if InFocus = -1 then
    InFocus := c
  else
  begin
    Graph.Paths[InFocus] += c;
    Graph.Paths[c] += InFocus;
  end;
end;

procedure ConnectNodes(a,b: Int32);
var
  i,n: Int32;
  p: TPoint;
  l1,l2: array[0..1] of TPoint;
begin
  if InIntArray(Graph.Paths[a], b) then
  begin
    Graph.Paths[a].Remove(b);
    Graph.Paths[b].Remove(a);
  end else
  begin
    if (InvalidPath(Graph.Nodes[a],Graph.Nodes[b])) then
    begin
      WriteLn('Error: Path crosses another path');
      Exit;
    end;

    Graph.Paths[a] += b;
    Graph.Paths[b] += a;
  end;
  (*
  l1 := [Graph.Nodes[a], Graph.Nodes[b]];
  SetLength(l2, 2);
  for i:=0 to High(Graph.Paths) do
  begin
    l2[0] := Graph.Nodes[i];
    for n in Graph.Paths[i] do
    begin
      l2[1] := Graph.Nodes[n];
      if LinesIntersect(l1,l2,p) then
      begin

      end;
    end;
  end;
  *)
end;

procedure DeleteNode(node: Int32);
var
  i,j,n,curr: Int32;
  marked: TIntArray;
begin
  marked += node;
  repeat
    curr := marked.Pop();

    for n in Graph.Paths[curr] do
    begin
      Graph.Paths[n].Remove(curr, True);
      if Length(Graph.Paths[n]) = 0 then
        marked += n;
    end;

    // offset remainding nodes
    for i:=0 to High(Graph.Paths) do
      for j:=0 to High(Graph.Paths[i]) do
        if Graph.Paths[i][j] > curr then
          Dec(Graph.Paths[i][j]);

    for i:=0 to High(marked) do
      if marked[i] > curr then Dec(marked[i]);

    // remove the node itself
    Delete(Graph.Paths, curr, 1);
    Delete(Graph.Nodes, curr, 1);
    Dec(NodeCount);
  until Length(marked) = 0;
end;

function FindPath(Graph: TWebGraph; Start, Goal: Int32): TIntArray;
type
  TNode = record
    Indices: TIntArray;
    Score: Double;
  end;
var
  queue: array of TNode;
  visited: TBoolArray;
  cIdx, pathIdx, n: Int32;
  current, node: TNode;
  altPaths: array of TIntArray;
  p,q: TPoint;

  function GetNextShortest(): TNode;
  var i,node: Int32;
  begin
    Result := queue[0];
    for i:=0 to High(queue) do
      if queue[i].Score < Result.Score then
      begin
        node   := i;
        Result := queue[i];
      end;
    Delete(queue, node, 1);
  end;
begin
  queue   := [[[start],0]];
  SetLength(visited, Length(Graph.Nodes));

  while Length(queue) <> 0 do
  begin
    current := GetNextShortest();
    cIdx := current.Indices[High(current.Indices)];
    if Visited[cIdx] then Continue; //skip overwrapping paths..
    Visited[cIdx] := True;

    if (cIdx = Goal) then
    begin
      Exit(current.Indices);
    end;

    p := Graph.Nodes[cIdx];
    for pathIdx in Graph.Paths[cIdx] do
    begin
      if not Visited[pathIdx] then
      begin
        q := Graph.Nodes[pathIdx];
        node.Indices := current.Indices + pathIdx;
        node.Score   := current.Score + Hypot(p.x-q.x, p.y-q.y);
        queue += node;
      end;
    end;
  end;
end;

procedure DrawWeb(Image: TMufasaBitmap; X1,Y1: Int32; Graph: TWebGraph);
var
  W,H,i,j: Int32;
  p,q: TPoint;
  Nodes,line: TPointArray;
begin
  W := Image.GetWidth-1;
  H := Image.GetHeight-1;

  Nodes := Copy(Graph.Nodes);
  Nodes.Offset(Point(-X1,-Y1));

  for i:=0 to High(Graph.Paths) do
  begin
    p := Nodes[i];
    if (not InRange(p.x,4,W-4)) or (not InRange(p.y,4,H-4)) then
      continue;

    for j:=0 to High(Graph.Paths[i]) do
    begin
      q := Nodes[Graph.Paths[i][j]];
      line := TPAFromLine(p.x,p.y,q.x,q.y);
      FilterPointsBox(line,0,0,W,H);
      Image.DrawTPA(line, $77FF77);
    end;
  end;

  for i:=0 to High(Nodes) do
    if InRange(Nodes[i].x,4,W-5) and InRange(Nodes[i].y,4,H-5) then
    begin
      if InFocus = i then
        Image.DrawCircle(Nodes[i],4,True,$FF0000)
      else
        Image.DrawCircle(Nodes[i],3,True,$0000FF);
    end;
end;

procedure DrawPath(Image: TMufasaBitmap; X1,Y1: Int32; Path: TIntArray; Graph: TWebGraph);
var
  i,W,H: Int32;
  p,q: TPoint;
  Nodes,line: TPointArray;
begin
  W := Image.GetWidth-1;
  H := Image.GetHeight-1;

  Nodes := Copy(Graph.Nodes);
  Nodes.Offset(Point(-X1,-Y1));

  p := Nodes[Path[0]];
  q := Nodes[Path[High(Path)]];

  if InRange(p.x,8,W-8) and InRange(p.y,8,H-8) then
    Image.DrawCircle(p, 8, True, $0000FF);

  if InRange(q.x,8,W-8) and InRange(q.y,8,H-8) then
    Image.DrawCircle(q, 8, True, $FF0000);

  for i:=0 to High(Path) do
  begin
    p := Nodes[Path[i]];
    if InRange(p.x,4,W-4) and InRange(p.y,4,H-4) then
      Image.DrawCircle(p,3,True, 0);

    if i < High(Path) then
    begin
      q := Nodes[Path[i+1]];
      line := TPAFromLine(p.x,p.y,q.x,q.y);
      FilterPointsBox(line,0,0,W,H);
      Image.DrawTPA(line, 0);
    end;
  end;
end;

// -----------------------------------------------------------------------------
// -----------------------------------------------------------------------------
// The GUI
procedure SideButtonStyle(Obj: TFormObject);
begin
  TButtonObject(Obj).SetDefaultStyles();
  Obj^.Styles.Padding     := [5,5,5,6];
  Obj^.Styles.BorderSize  := 0;
  Obj^.Styles.BorderColor := SlackGUI.Palette[clBackground4];
  Obj^.Styles.Background  := SlackGUI.Palette[clBackground0];
  Obj^.Styles.FontSize    := 8;

  Obj^.Styles2.Background := SlackGUI.Palette[clHighlighted2];
  Obj^.Styles2.BorderColor:= SlackGUI.Palette[clHighlighted2];
  Obj^.Styles2.FontSize   := Obj^.Styles.FontSize;
  Obj^.Styles2.FontColor  := SlackGUI.Palette[clBackground0];
  Obj^.Styles2.Padding    := Obj^.Styles.Padding;
end;

procedure OnCloseWindow(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
begin
  SlackGUI.Form.Close();
end;

procedure OnDeleteNodeBtn(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
begin
  DeleteNode(InFocus);
  InFocus := High(Graph.Nodes);
end;

procedure OnPrintBtn(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
begin
  Write('Index(',InFocus,'), ');
  Write('Node(', Graph.Nodes[InFocus],'), ');
  Write('Paths(', Graph.Paths[InFocus],')');
  WriteLn();
end;

procedure OnCopyBtn(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
var s: string;
begin
  s := 'Graph.Nodes := '+ ToString(Graph.Nodes) + ';';
  s += #13#10;
  s += 'Graph.Paths := '+ ToStr(Graph.Paths) + ';';
  SetClipBoard(s);
end;

procedure OnRunTest(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
begin
  IsTesting := not IsTesting;
  if IsTesting then
  begin
    TestPath := [];
    Sender^.Styles.BorderColor := SlackGUI.Palette[clBackground0];
    Sender^.Styles.Background  := SlackGUI.Palette[clHighlighted2];
    Sender^.Styles.FontColor   := SlackGUI.Palette[clBackground0];
    Sender^.Styles2.Background := SlackGUI.Palette[clHighlighted2];
    Sender^.Styles2.FontColor  := SlackGUI.Palette[clBackground0];
  end else
  begin
    SideButtonStyle(Sender);
    Swap(Sender^.Styles, Sender^.Styles2);
  end;
end;

procedure OnRunCheck(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
var count,node,i,j:Int32;
begin
  for i:=0 to High(Graph.Paths) do
    for j:=0 to High(Graph.Paths[i]) do
    begin
      node := Graph.Paths[i][j];
      if not InIntArray(Graph.Paths[node], i) then
      begin
        Graph.Paths[node] += i;
        Inc(count);
      end;
    end;
  if count <> 0 then
    WriteLn('Check completed: Fixed `', count,'` pathways!')
  else
    WriteLn('Check completed: All was good!');
end;

procedure OnPrintSep(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
begin
  WriteLn(#13#10);
end;

procedure DrawMap(Self: TFormObject);
var
  newW, newH, X,Y,W,H,i,j: Int32;
  p,q: TPoint;
  tmp: TBitmap;
  muf: TMufasaBitmap;
  B: TRect;
  tmpTPA,line: TPointArray;
begin
  SlackGUI.RenderBasicBlock(Self);

  with self.Bounds do
  begin
    X := Left + 5;
    Y := Top  + 5;
    W := Right  - X - 5;
    H := Bottom - Y - 5;
  end;

  muf := WorldImg.Copy(CurrX,CurrY, Min(WorldImg.GetWidth,CurrX+W)-1,Min(WorldImg.GetHeight, CurrY+H)-1);
  muf.SetList(client.GetMBitmaps);
  client.GetMBitmaps.AddBMP(muf);
  DrawWeb(muf, CurrX, CurrY, Graph);

  if (IsTesting) and (Length(TestPath) > 0) then
    DrawPath(muf, CurrX, CurrY, TestPath, Graph);

  tmp := muf.ToTBitmap;
  SlackGUI.Canvas.Draw(x,y,tmp);
  tmp.Free();
  muf.Free();
end;


procedure ImgPress(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
var
  dx,dy,idx: Int32;
begin
  if Button = mbLeft then
  begin
    tmpX := X;
    tmpY := Y;
    startX := CurrX;
    startY := CurrY;

    if (InFocus <> -1) then
      with Sender.Bounds(True) do
      begin
        dx := CurrX + X - Left;
        dy := CurrY + Y - Top;
        if Distance(Graph.Nodes[InFocus], Point(dx-5,dy-5)) < 5 then
          IsDraggingNode := True;
      end;

    if(not IsDraggingNode) then
      IsDragging := True;
  end;
end;

procedure ImgMove(Sender: TFormObject; Shift: TShiftState; X,Y: Int32); static;
begin
  if IsDragging then
  begin
    CurrX := Max(0, CurrX + tmpX-X);
    CurrY := Max(0, CurrY + tmpY-Y);
    tmpX := X;
    tmpY := Y;
  end;

  if IsDraggingNode then
    with Sender.Bounds(True) do
      Graph.Nodes[InFocus] := Point(CurrX + X - Left, CurrY + Y - Top);
end;

procedure ImgRelease(Sender: TFormObject; Button: TMouseButton; Shift: TShiftState; X,Y: Int32); static;
var
  dx,dy,c,idx: Int32;
  DidChange: Boolean;
  t: Double;
begin
  if (Button = mbLeft) and (IsDragging) then
  begin
    CurrX := Max(0, CurrX + tmpX-X);
    CurrY := Max(0, CurrY + tmpY-Y);
    IsDragging := False;
    DidChange := (StartX <> CurrX) or (StartY <> CurrY);
  end else
  if (Button = mbLeft) and (IsDraggingNode) then
  begin
    with Sender.Bounds(True) do
      Graph.Nodes[InFocus] := Point(CurrX + X - Left, CurrY + Y - Top);
    IsDraggingNode := False;
    Exit;
  end;

  if (Button = mbLeft) and (not DidChange) then
    with Sender.Bounds(True) do
    begin
      dx := CurrX + X - Left - 5;
      dy := CurrY + Y - Top - 5;

      idx := CheckForNearbyNode([dx,dy]);

      if IsTesting then
      begin
        if idx <> -1 then
        begin
          t := PerformanceTimer();
          TestPath := FindPath(Graph, InFocus, idx);
          WriteLn('Path generated in ', Round(PerformanceTimer - t),'ms | Found ', Length(TestPath), ' nodes');
        end;
        Exit;
      end;

      if (idx = -1) then                   // add node
        AddNode(Point(dx,dy))
      else if (not(ssShift in Shift)) then // select node
        InFocus := idx
      else if (InFocus <> idx) then        // connect node
        ConnectNodes(InFocus, idx);
    end;
end;

procedure TSlackGUI.Init(); static; override;
var
  TitleBar, TopObject, Button, MapPath: TFormObject;
  W, H: Int32;
begin
  SlackGUI.Width  := 990;
  SlackGUI.Height := 620;
  SlackGUI.Palette := DARK_NEUTRAL;

  inherited;

  W := SlackGUI.Width;
  H := SlackGUI.Height;

  with (TopObject := SlackGUI.AddObject(FormObject('Stub')))^ do
  begin
    Position   := bpRelative;
    Styles.Background  := SlackGUI.Palette[clBackground2];
    Styles.BorderColor := SlackGUI.Palette[clBorder1];
    Styles.BorderSize  := 0;
    Styles.Padding     := [];
    RenderProc := @RenderBasicBlock;
  end;

  with TTitlebarObject(TitleBar := SlackGUI.AddObject(TitlebarObject('TitleBar', [0,0,W,29], TopObject)))^ do
  begin
    Text       := 'Web Walk Generator';
    RenderProc := @RenderTitlebar;

    Styles.Background  := $1F1A13;
    Styles.BorderColor := SlackGUI.Palette[clBorder1];
    Styles.BorderSize  := 0;
    Styles.FontStyle := [fsBold];
    Styles.FontColor := SlackGUI.Palette[clText1];
    Styles.FontSize  := 12;
    Styles.FontName  := 'Tahoma';
  end;

  with TButtonObject(SlackGUI.AddObject(ButtonObject('GUIClose', TitleBar.Bounds, TitleBar)))^ do
  begin
    Bounds := Rect(Bounds.Right-26, Bounds.Top, Bounds.Right, Bounds.Bottom);
    Text   := 'X';
    Styles.FontName   := 'MS Sans Serif';
    Styles.Background := SlackGUI.Palette[clBackground0];
    Styles.BorderSize := 0;
    Styles.FontSize   := 13;
    Styles.FontStyle  := [fsBold];
    Styles.FontColor  := SlackGUI.Palette[clText3];
    Styles.Padding    := [7,5,0,0];

    Styles2 := Styles;
    Styles2.Background := clRed;
    Styles2.FontColor  := SlackGUI.Palette[clText1];

    RenderProc := @RenderTextButton;
    OnClick    := @OnCloseWindow;
  end;

  with TButtonObject(Button := SlackGUI.AddObject(ButtonObject('REMOVE', [10,40,65], TopObject)))^ do
  begin
    RenderProc := @RenderTextButton;
    SideButtonStyle(Button);
    Text := 'REMOVE';
    OnClick := @OnDeleteNodeBtn;
  end;

  with TButtonObject(Button := SlackGUI.AddObject(ButtonObject('COPY', [10,65,65], TopObject)))^ do
  begin
    RenderProc := @RenderTextButton;
    SideButtonStyle(Button);
    Text := 'COPY';
    OnClick := @OnCopyBtn;
  end;

  with TButtonObject(Button := SlackGUI.AddObject(ButtonObject('TEST', [10,90,65], TopObject)))^ do
  begin
    RenderProc := @RenderTextButton;
    SideButtonStyle(Button);
    Text := 'TEST';
    OnClick := @OnRunTest;
  end;

  with TButtonObject(Button := SlackGUI.AddObject(ButtonObject('CHECK', [10,115,65], TopObject)))^ do
  begin
    RenderProc := @RenderTextButton;
    SideButtonStyle(Button);
    Text := 'CHECK';
    OnClick := @OnRunCheck;
  end;

  with TButtonObject(Button := SlackGUI.AddObject(ButtonObject('PRINT', [10,200,65], TopObject)))^ do
  begin
    RenderProc := @RenderTextButton;
    SideButtonStyle(Button);
    Text := 'PRINT';
    OnClick := @OnPrintBtn;
  end;

  with TButtonObject(Button := SlackGUI.AddObject(ButtonObject('SEPARATOR', [10,225,65], TopObject)))^ do
  begin
    RenderProc := @RenderTextButton;
    SideButtonStyle(Button);
    Text := '---------';
    OnClick := @OnPrintSep;
  end;

  with (MapPath := SlackGUI.AddObject(FormObject('MapPath', [65,40,-10,-10], TopObject)))^ do
  begin
    Position := bpRelative;
    Styles.Background  := SlackGUI.Palette[clBackground2];
    Styles.BorderColor := SlackGUI.Palette[clBorder1];
    Styles.BorderSize  := 0;
    Styles.Padding := [];
    RenderProc := @RenderBasicBlock;

    with SlackGUI.AddObject(FormObject('Image''includes/RSWalker/maps/World.png');
  SlackGUI.Show();
  WorldImg.Free();
end.