I wrote a little sml code to generate the diagrams, implementing something akin to TeX's (and many other programs', I'm sure) notion of "stretchable glue". At one point I had an obvious bug that scaling all glue by a constant factor affected the results, which it totally shouldn't have — stretchability is only meaningful up to a constant factor. So I made an abstract type for stretchability, and edited my program until it should have been right, but lo and behold there was a type error: I had swapped around two elements of a tuple that prior to abstraction were both just real numbers.
Score one more for types!
signature TORSOR =
sig
type t
val tor : real -> t
val ratio : t * t -> real
val max : t * t -> t
val + : t * t -> t
end
structure Torsor :> TORSOR =
struct
type t = real
fun tor x = 20.0 * x
fun ratio (x:real, y) = x / y
fun max (x, y) = Real.max (x, y)
fun op+ (x, y) = Real.+ (x, y)
end
structure Comp =
struct
val tor = Torsor.tor
fun r2s r = if r < 0.0 then "-" ^ Real.toString (~r) else Real.toString r
datatype diag = Cell
| Concat of diag list
fun single 0 = Concat[Cell]
| single n = Concat[Cell, single (n-1), Cell]
fun horizontal n = Concat[Cell, single n, Cell, single n, Cell]
fun nwrap 0 c = c
| nwrap n c = Concat[Cell, nwrap (n-1) c, Cell]
type mag = real
type glue = mag * Torsor.t (* extent, stretch *)
type xy = mag * mag
datatype layout = Hbox of Torsor.t * layout list (* t is stretchiness *)
| Vbox of Torsor.t * layout list
| Prim of (xy -> xy -> string) * glue * glue (* SVG, xglue, yglue *) (* SVG takes pos, size *)
fun sum l = foldl op+ 0.0 l
fun foldx f [] = raise Match
| foldx f [x] = x
| foldx f (h::tl) = f (h,foldx f tl)
fun gplus ((m:real,s),(m',s')) = (m + m', Torsor.+(s, s'))
fun fst (x,y) = x
fun gsum l = foldl gplus (0.0, tor 0.0) l
fun gmaxs l = foldx Real.max (map fst l)
fun ljoin sep [] = [sep]
| ljoin sep [x] = [sep, x, sep]
| ljoin sep (h::tl) = sep :: h :: ljoin sep tl
val HSTRETCH = tor 50.0
val VSTRETCH = tor 50.0
val VXGLUE = (2.0, tor 50.0)
val VYGLUE = (2.0, tor 0.0)
val HXGLUE = (2.0, tor 0.0)
val HYGLUE = (2.0, tor 50.0)
val HSEP = Prim ((fn x => fn y => ""), (1.5, tor 5.0), (0.0, tor 0.0))
val VSEP = Prim ((fn x => fn y => ""), (0.0, tor 0.0), (1.5, tor 5.0))
fun marker 1 = ""
| marker n = "marker-end=\"url(#Triangle)\""
fun dc (false, dimension) (px,py) (sx,sy) =
"<line x1=\"" ^ r2s (px + sx/2.0) ^ "\" x2 = \"" ^ r2s (px + sx/2.0) ^ "\" y1=\""
^ r2s py ^ "\" y2=\"" ^ r2s (py + sy) ^ "\" style=\"file:none;stroke:black;\" " ^ marker dimension ^ " />\n"
| dc (true, dimension) (px, py) (sx, sy) =
"<line y1=\"" ^ r2s (py + sy/2.0) ^ "\" y2 = \"" ^ r2s (py + sy/2.0) ^ "\" x1=\""
^ r2s px ^ "\" x2=\"" ^ r2s (px + sx) ^ "\" style=\"file:none;stroke:black;\" " ^ marker dimension ^ "/>\n"
fun drawcell (p, d) pos size = dc (p, d) pos size ^ "\n" ^ dc (p, 1) pos size
fun layout c =
let
fun go true n Cell = Prim (drawcell (true, n), VXGLUE, VYGLUE)
| go false n Cell = Prim (drawcell (false, n), HXGLUE, HYGLUE)
| go true n (Concat ds) = Hbox (HSTRETCH, ljoin HSEP (map (go false (n+1)) ds))
| go false n (Concat ds) = Vbox (VSTRETCH, ljoin VSEP (map (go true (n+1)) ds))
in
go true 0 c
end
fun xextent (Hbox (st, ls)) = gsum (map xextent ls)
| xextent (Vbox (st, ls)) = (gmaxs (map xextent ls), st)
| xextent (Prim (svg, xg, yg)) = xg
fun yextent (Hbox (st, ls)) = (gmaxs (map yextent ls), st)
| yextent (Vbox (st, ls)) = gsum (map yextent ls)
| yextent (Prim (svg, xg, yg)) = yg
(* distribute takes the amount of slack, and the total amount of stretch
and a glue and computes the size of an item *)
fun distribute sl pst (m : real, st) = m + sl * Torsor.ratio(st, pst)
fun render (px,py) (sx,sy) (l as Hbox (s, ls)) =
let
val (mx,stx) = xextent l
val (my,sty) = yextent l
(* its is a list of pairs of items and extents *)
val its = map (fn it => (it, (distribute (sx - mx) stx (xextent it)))) ls
fun addone ((item, sx'), (px', str)) = (px' + sx', str ^ render (px', py) (sx', sy) item)
val (_, str) = foldl addone (px, "") its
in
str
end
| render (px,py) (sx,sy) (l as Vbox (s, ls)) =
let
val (mx,stx) = xextent l
val (my,sty) = yextent l
(* its is a list of pairs of items and extents *)
val its = map (fn it => (it, (distribute (sy - my) sty (yextent it)))) ls
fun addone ((item, sy'), (py', str)) = (py' + sy', str ^ render (px, py') (sx, sy') item)
val (_, str) = foldl addone (py, "") its
in
str
end
| render pos size (Prim (svg, xg, yg)) = svg pos size
fun xml s =
"<?xml version=\"1.0\" standalone=\"no\"?>\n" ^
"<svg width=\"100%\" height=\"100%\" version=\"1.1\" " ^
"xmlns=\"http://www.w3.org/2000/svg\">\n" ^ (StringUtil.readfile "defs") ^
s ^ "\n</svg>"
val size = (100.0, 100.0)
fun row ~1 n pos = ""
| row m n (px, py) = render (px,py) size (layout (nwrap m (horizontal n))) ^
row (m-1) (n+1) (px + 120.0, py)
fun diag 0 (px, py) = row 0 0 (px, py)
| diag n (px, py) = row n 0 (px, py) ^ diag (n-1) (px + 60.0, py - 120.0)
fun go () =
let
val s = xml (diag 7 (0.0,0.0))
in
StringUtil.writefile "/home/jcreed/desktop/diagram.svg" s
end
end
