# 19oct23 Software Lab. Alexander Burger
(symbols 'vip~draw 'vip 'pico)
(local) (*DX *DY *PX *PY *Draw *Boxes)
(zero *DX *DY)
# Drawing primitives
(local) (point hline vline go up down left right rect label)
(de point (X Y C)
(inc 'X *DX)
(inc 'Y *DY)
(let P
(or
(nth *Draw Y)
(nth (setq *Draw (need (- Y) *Draw)) Y) )
(set
(or
(nth (car P) X)
(nth
(set P (need (- X) (car P) (name " ")))
X ) )
(name C) ) ) )
(de hline (C X Y X2 A)
(point X Y C)
(if (> X2 X)
(do (- X2 X)
(point (inc 'X) Y "-") )
(do (- X X2)
(point (dec 'X) Y "-") ) )
(and A (point X Y A)) )
(de vline (C X Y Y2 A)
(point X Y C)
(if (> Y2 Y)
(do (- Y2 Y)
(point X (inc 'Y) "|") )
(do (- Y Y2)
(point X (dec 'Y) "|") ) )
(and A (point X Y A)) )
(de go (X Y C)
(point (setq *PX X) (setq *PY Y) C) )
(de up (N C)
(vline "|" *PX (dec *PY) (dec '*PY N) C) )
(de down (N C)
(vline "|" *PX (inc *PY) (inc '*PY N) C) )
(de left (N C)
(hline "-" (dec *PX) *PY (dec '*PX N) C) )
(de right (N C)
(hline "-" (inc *PX) *PY (inc '*PX N) C) )
(de rect (X Y X2 Y2)
(hline "+" X Y (dec X2))
(vline "+" X2 Y (dec Y2))
(hline "+" X2 Y2 (inc X))
(vline "+" X Y2 (inc Y)) )
(de label (X Y Txt)
(for C (chop Txt)
(point X Y C)
(inc 'X) ) )
# Box
(local) (+Box mx> my> hv>)
(class +Box)
# id x y x2 y2 dx dy h v
(dm mx> ()
(*/ (+ (: x) (: x2)) 2) )
(dm my> ()
(*/ (+ (: y) (: y2)) 2) )
(dm hv> ()
(for L (: h)
(loop
(apply hline (++ L))
(NIL L)
(apply vline (++ L))
(NIL L) ) )
(for L (: v)
(loop
(apply vline (++ L))
(NIL L)
(apply hline (++ L))
(NIL L) ) ) )
# Draw box
(local) (block box)
(private) (X Y DX DY Txt Prg)
(de block (X Y . Prg)
(let (*DX (dec X) *DY (dec Y))
(run Prg) ) )
(de box (X Y DX DY Txt . Prg)
(with
(new '(+Box)
'id (if (atom Txt) Txt (car Txt))
'x (inc 'X *DX)
'y (inc 'Y *DY)
'x2 (+ X DX)
'y2 (+ Y DY)
'dx DX
'dy DY )
(queue '*Boxes This)
(let (*DX 0 *DY 0)
(rect (: x) (: y) (: x2) (: y2))
(when (fin Txt)
(label
(+ (: x) (*/ (- (: dx) (length @)) 2))
(+ (: y) (*/ (: dy) 2))
@ ) ) )
(let (*DX X *DY Y)
(run Prg) ) ) )
# Draw arrow
(local) arrow
(de arrow (Id1 Id2)
(with
(if (num? Id1)
(get *Boxes Id1)
(find '((This) (= Id1 (: id))) *Boxes) )
(let? B
(if (num? Id2)
(get *Boxes Id2)
(find '((This) (= Id2 (: id))) *Boxes) )
(let (X (mx> This) Y (my> This) X2 (mx> B) Y2 (my> B))
(cond
((> (; B y) (: y2)) # Above
(cond
((or
(>= 3 (- (; B y) (: y2)))
(>= (inc X2) X (dec X2)) )
(push (:: v)
(list
(list "+" X (: y2) (dec (; B y)) "v") ) ) )
((> (; B y) (+ 4 (: y2)))
(push (:: v)
(let M (/ (+ (: y2) (; B y)) 2)
(list
(list "+" X (: y2) (dec M))
(list "+" X M X2)
(list "+" X2 M (dec (; B y)) "v") ) ) ) )
((> (; B x) (+ 2 X)) # Left
(push (:: v)
(list
(list "+" X (: y2) (dec Y2))
(list "+" X Y2 (dec (; B x)) ">") ) ) )
((> X (+ 2 (; B x2))) # Right
(push (:: v)
(list
(list "+" X (: y2) (dec Y2))
(list "+" X Y2 (inc (; B x2)) "<") ) ) ) ) )
((> (: y) (; B y2)) # Below
(cond
((or
(>= 3 (- (: y) (; B y2)))
(>= (inc X2) X (dec X2)) )
(push (:: v)
(list
(list "+" X (: y) (inc (; B y2)) "\^") ) ) )
((> (: y) (+ 4 (; B y2)))
(push (:: v)
(let M (*/ (+ (: y) (; B y2)) 2)
(list
(list "+" X (: y) (inc M))
(list "+" X M X2)
(list "+" X2 M (inc (; B y2)) "\^") ) ) ) )
((> (; B x) (+ 2 X)) # Left
(push (:: v)
(list
(list "+" X (: y) (inc Y2))
(list "+" X Y2 (dec (; B x)) ">") ) ) )
((> X (+ 2 (; B x2))) # Right
(push (:: v)
(list
(list "+" X (: y) (inc Y2))
(list "+" X Y2 (inc (; B x2)) "<") ) ) ) ) )
(T # Besides
(cond
((> (; B x) (: x2)) # Left
(push (:: h)
(if (= Y Y2)
(list
(list "+" (: x2) Y (dec (; B x)) ">") )
(let M (*/ (+ (: x2) (; B x)) 2)
(list
(list "+" (: x2) Y (dec M))
(list "+" M Y Y2)
(list "+" M Y2 (dec (; B x)) ">") ) ) ) ) )
((> (: x) (; B x2)) # Right
(push (:: h)
(if (= Y Y2)
(list
(list "+" (: x) Y (inc (; B x2)) "<") )
(let M (*/ (+ (: x) (; B x2)) 2)
(list
(list "+" (: x) Y (inc M))
(list "+" M Y Y2)
(list "+" M Y2 (inc (; B x2)) "<") ) ) ) ) ]
# Draw cell structures
(local) (cell cells)
(de cell (X Y Car Cdr)
(let A (max 6 (+ 3 (length (setq Car (sym Car)))))
(box X Y A 2
(cons
(pack (+ X *DX) "/" (+ Y *DY))
Car )
(let B 6
(setq Cdr
(cond
((pair Cdr) " ---")
(Cdr
(prog1
(sym @)
(setq B (max 6 (+ 3 (length @)))) ) )
(T "/") ) )
(box A 0 B 2
(cons (pack X "/" Y "+") Cdr) )
(+ A B) ) ) ) )
(de cells (X Y Any)
(let Pos (list X)
(recur (Any Y Pos)
(let (Y2 (+ Y *DY) Last)
(while (pair Any)
(use D
(if (atom (car Any))
(setq D (cell (car Pos) Y (++ Any) Any))
(ifn (cdr Pos)
(con Pos (list (car Pos)))
(let (P @ M (car Pos))
(for (A (car Any) (pair A) (car A))
(setq M (max M (++ P))) )
(map
'((L) (set L (max M (car L))))
Pos ) ) )
(setq D
(cell (car Pos) Y '| (cdr Any)) )
(recurse (++ Any) (+ Y 5) (cdr Pos))
(let X2 (+ (car Pos) *DX)
(arrow
(pack X2 "/" Y2)
(pack X2 "/" (+ Y2 5)) ) ) )
(let X2 (+ (car Pos) *DX)
(when Last
(arrow @ (pack X2 "/" Y2)) )
(setq Last (pack X2 "/" Y2 "+")) )
(inc Pos (+ 6 D)) ) ) ) ) ) )
# Override +Buffer methods in object
(let? *Class (isa '+Buffer This)
(dm view> (Win)
(=: view T)
(off *Draw *Boxes)
(symbols '(vip~draw vip pico)
(evCmd (load (fName (: file)))) )
(mapc 'hv> *Boxes)
(with Win
(scratch (tmp "draw") *Draw) ) )
(dm save> (Win)
(super Win)
(when (: view)
(view> This Win) ) ) )
### Debug ###
`*Dbg
(de pico~cells @
(off *Draw *Boxes)
(let Y 1
(while (args)
(let V (next)
(cond
((pair V)
(cells 1 Y V)
(setq Y (+ 3 (length *Draw))) )
(V
(label 1 Y V)
(inc 'Y) ) ) ) ) )
(mapc 'hv> *Boxes)
(out (tmp "cells") (mapc prinl *Draw))
(pico~vi (tmp "cells")) )