The Tower of Hanoi with graphics, in SATySFi

hanoi.satyh

% hanoi.satyh: Tower of Hanoi with graphics
%
% Copyright (c) 2022 Takayuki YATO (aka. "ZR")
%   GitHub:   https://github.com/zr-tex8r
%   Twitter:  @zr_tex8r
% Distributed under the MIT License.

%=========================================================== module Hanoi
module Hanoi : sig

val document : int -> document

end = struct

let (width, height) = (240pt, 180pt)
let clr-rod  = RGB (1.0, 0.8, 0.0)
let clr-text = RGB (0.0, 0.4, 0.0)
let clr-disk r = RGB (0.0, 0.4 *. r, 0.8 *. (1. -. r))

let reverse xs =
  let-rec iter | [] rs = rs
               | (x::xs) rs = iter xs (x :: rs)
  in
  iter xs []

let picture ctx order count (roda, rodb, rodc) porg =
  let gs = shift-graphics porg in
  let rect c (x, y) (w, h) =
    start-path (x, y) |> line-to (x +' w, y)
    |> line-to (x +' w, y +' h) |> line-to (x, y +' h)
    |> close-with-line |> fill c |> gs
  in
  let one-rod rx rod grs =
    let-rec iter | _ [] = grs
                 | k (d::ds) =
      let (fd, fk, ro) = (float d, float k, 1. /. (float order)) in
      let (dw, dh) = (30pt *' (fd *. ro) +' 20pt, 90pt *' ro) in
      let (dx, dy) = (rx -' dw *' 0.5, dh *' fk +' 40pt) in
      let gd = rect (clr-disk (fd *. ro)) (dx, dy) (dw, dh) in
      gd :: iter (k + 1) ds
    in
    let grod = rect clr-rod (rx -' 5pt, 30pt) (10pt, 110pt) in
    grod :: iter 0 (reverse rod)
  in
  let ib-text fsize it =
    read-inline (ctx |> set-font-size fsize) it
  in
  let ibstep = ib-text 10pt {Step} in
  let ibcount = ib-text 16pt (arabic count |> embed-string) in
  let (wcount, _, _) = get-natural-metrics ibcount in
  [
    rect clr-rod (30pt, 30pt) (180pt, 10pt);
    draw-text (80pt, 150pt) ibstep |> gs;
    draw-text (160pt -' wcount, 150pt) ibcount |> gs;
  ] |> one-rod 60pt roda |> one-rod 120pt rodb |> one-rod 180pt rodc

let-inline ctx \dummy-math _ = inline-nil

let make-document body =
  let ctx = get-initial-context width (command \dummy-math) in
  page-break (UserDefinedPaper (width, height))
    (fun _ -> (| 
      text-origin = (0pt, 0pt); text-height = height;
    |))
    (fun _ -> (| 
      header-origin = (0pt, 0pt); header-content = block-nil;
      footer-origin = (0pt, 0pt); footer-content = block-nil;
    |))
    (body ctx)


type rod = RodA | RodB | RodC

let make-page ctx order cnt cfg =
  let pic = picture ctx order cnt cfg in
  let ib = inline-graphics width height 0pt pic in
  line-break true true ctx (ib ++ inline-fil)

let solve ctx order =
  let-rec init-rod | 0 rs = rs
                   | k rs = init-rod (k - 1) (k :: rs)
  in
  let-rec get-cfg | (RodA) (a, _, _) = a
                  | (RodB) (_, b, _) = b
                  | (RodC) (_, _, c) = c
  in
  let-rec set-cfg | (RodA) r (a, b, c) = (r, b, c)
                  | (RodB) r (a, b, c) = (a, r, c)
                  | (RodC) r (a, b, c) = (a, b, r)
  in
  let move from to cfg =
    let (d::rfrom, rto) = (get-cfg from cfg, get-cfg to cfg) in
    cfg |> set-cfg from rfrom |> set-cfg to (d :: rto)
  in
  let-rec solve-sub | cnt cfg 0 _ _ _ = (block-nil, cnt, cfg)
                    | cnt cfg ord from aux to =
    let (ps1, cnt, cfg) = solve-sub cnt cfg (ord - 1) from to aux in
    let (cnt, cfg) = (cnt + 1, cfg |> move from to) in
    let page = make-page ctx order cnt cfg in
    let (ps2, cnt, cfg) = solve-sub cnt cfg (ord - 1) aux from to in
    (ps1 +++ page +++ ps2, cnt, cfg)
  in
  let init-cfg = ((init-rod order []), [], []) in
  let (ps, _, _) = solve-sub 0 init-cfg order RodA RodB RodC in
  make-page ctx order 0 init-cfg +++ ps

let document order =
  make-document (fun ctx -> solve ctx order)

end
%===========================================================

%% EOF

hanoi17.saty

@import: hanoi
Hanoi.document 17

解説記事→SATySFiで10万ページの文書をつくる話