SATySFi：トッテモ実用的な文書（アレの日用）

pi.saty

@require: stdja

%--------------------------------------- parameters

let mp-precision = 30000
let mp-block-digits = 9

%--------------------------------------- helpers

let-rec x-ex10 | 0 = 1
               | n = 10 * x-ex10 (n - 1)

let x-iota n =
  let-rec itr | 0 rs = 0 :: rs
              | k rs = itr (k - 1) (k :: rs)
  in
  itr (n - 1) []

let x-rev xs =
  let-rec itr | [] rs = rs
              | (x::xs) rs = itr xs (x::rs)
  in
  itr xs []

let x-info str = display-message (`###` ^ str)

%--------------------------------------- multiprecision arithmetic

let mp-size = (mp-precision + mp-precision / 1000) / mp-block-digits + 2
let mp-rdx = x-ex10 mp-block-digits

let mp-make v =
  let-rec itr | 0 xs = xs
              | n xs = itr (n - 1) (0 :: xs)
  in
  (v :: itr mp-size [])

let mp-div xs v =
  let-rec itr | _ [] = []
              | c (x::xs) =
    let t = c * mp-rdx + x in
    (t / v) :: itr (t mod v) xs
  in
  itr 0 xs

let mp-div-chk-r xs v =
  let-rec itr | _ [] rs eqz = (rs, eqz)
              | c (x::xs) rs eqz =
    let t = c * mp-rdx + x in
    let u = t / v in
    itr (t mod v) xs (u :: rs) (eqz && u == 0)
  in
  itr 0 xs [] true

let mp-div-r xs v =
  let-rec itr | _ [] rs = rs
              | c (x::xs) rs =
    let t = c * mp-rdx + x in
    itr (t mod v) xs ((t / v) :: rs)
  in
  itr 0 xs []

let mp-r-add xs ys =
  let-rec itr | [] _ _ rs = rs
              | (x::xs) (y::ys) c rs =
    let r = x + y + c in
    if r < mp-rdx then itr xs ys 0 (r::rs)
    else itr xs ys 1 ((r - mp-rdx) :: rs)
              | _ _ _ rs = rs
  in
  itr xs ys 0 []

let mp-r-sub xs ys =
  let-rec itr | [] _ _ rs = rs
              | (x::xs) (y::ys) c rs =
    let r = x - y - c in
    if r >= 0 then itr xs ys 0 (r::rs)
    else itr xs ys 1 ((r + mp-rdx) :: rs)
              | _ _ _ rs = rs
  in
  itr xs ys 0 []

%--------------------------------------- Machin's formula

let mp-a-atan-rcp-b a b =
  let xs = x-rev (mp-div-r (mp-make a) b) in
  let bb = b * b in
  let-rec itr xs n add ss =
    let xs = x-rev (mp-div-r xs bb) in
    let (tr, eqz) = mp-div-chk-r xs n in
    if eqz then (ss, n)
    else
      let ss = (if add then mp-r-add else mp-r-sub) (x-rev ss) tr in
      itr xs (n + 2) (not add) ss
  in
  itr xs 3 false xs

let mp-pi () =
  let () = x-info (`start`) in
  let (t1s, n1) = mp-a-atan-rcp-b 16 5 in
  let () = x-info (`atan(1/5) neede terms up to:` ^ (arabic n1)) in
  let (t2s, n2) = mp-a-atan-rcp-b 4 239 in
  let () = x-info (`atan(1/239) neede terms up to:` ^ (arabic n2)) in
  let pis = mp-r-sub (x-rev t1s) (x-rev t2s) in
  let () = x-info (`done`) in
  pis

%--------------------------------------- display

let mpd-bsize = 10
let mpd-lsize = 10
let mpd-gsize = (mp-precision / mpd-bsize) / mpd-lsize

let mpd-space = string-unexplode [32]
let mpd-empty = string-unexplode []

let-rec mpd-digit | ([], _) = (0, ([], 0))
                  | (x::xs, 0) = mpd-digit (xs, mp-rdx / 10)
                  | (x::xs, dc) = ((x / dc) mod 10, (x::xs, dc / 10))

let mpd-block mpd =
  let-rec itr | mpd 0 wrd = (wrd, mpd)
              | mpd k wrd =
    let (d, mpd1) = mpd-digit mpd in
      itr mpd1 (k - 1) (wrd ^ arabic d)
  in
  itr mpd mpd-bsize mpd-empty

let mpd-line mpd =
  let-rec itr | mpd 0 wrd = (wrd, mpd)
              | mpd k wrd =
    let sep = if k > 1 then mpd-space else mpd-empty in
    let (b, mpd1) = mpd-block mpd in
      itr mpd1 (k - 1) (wrd ^ b ^ sep)
  in
  itr mpd mpd-lsize mpd-empty

%--------------------------------------- typesetting

let pt-font-size = 8pt
let pt-head-font-size = 16pt

let pt-form-para ctx itxs =
  let-rec itr | [] inl = inl
              | (itx::itxs) inl = itr itxs (inl ++ (read-inline ctx itx))
  in
  line-break true true ctx ((itr itxs inline-nil) ++ inline-fil)

let pt-out-block ctx mpd =
  let-rec itr | _ 0 blks = blks
              | mpd m blks =
    let (wrd, mpd) = mpd-line mpd in
    itr mpd (m - 1) (blks +++ (pt-form-para ctx [embed-string wrd]))
  in
  itr mpd mpd-gsize block-nil

let pt-out-head ctx v =
  pt-form-para ctx [
    {${\pi} =\ }; embed-string (arabic v); {.};
  ]

let-block ctx +PiDigits =
  let ctx1 = ctx |> set-font-size pt-head-font-size 
                 |> set-paragraph-margin 8pt 8pt in
  let ctx2 = ctx |> set-font-size pt-font-size 
                 |> set-paragraph-margin 4pt 4pt in
  let pis = mp-pi () in
  let ((t, _), (x::_)) = (mpd-line(pis, 0), pis) in
  let () = x-info (`pi=` ^ (arabic x) ^ `.` ^ t) in
  (pt-out-head ctx1 x) +++ (pt-out-block ctx2 (pis, 0))

in

StdJa.document (|
  title = {今日はコレの日！};
  author = {某ZR};
  show-title = true;
  show-toc = false;
|) '<
  +PiDigits;
>