Created
March 13, 2018 16:47
-
-
Save zr-tex8r/4673b452e59868c658008aeab3b8cf64 to your computer and use it in GitHub Desktop.
SATySFi:トッテモ実用的な文書(アレの日用)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
@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; | |
> |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment