-
Notifications
You must be signed in to change notification settings - Fork 83
/
stdjabook.satyh
636 lines (541 loc) · 20.5 KB
/
stdjabook.satyh
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
% -*- coding: utf-8 -*-
@require: pervasives
@require: gr
@require: list
@require: math
@require: code
@require: color
@require: option
@require: annot
@require: footnote-scheme
type config = (|
paper-size : page;
show-pages : bool;
text-width : length;
text-height : length;
text-origin : point;
header-origin : point;
footer-origin : point;
header-width : length;
footer-width : length;
|)
module StdJaBook : sig
val default-config : config
val document : 'a -> config ?-> block-text -> document
constraint 'a :: (|
title : inline-text;
author : inline-text;
show-toc : bool;
show-title : bool;
|)
val font-latin-roman : string * float * float
val font-latin-bold : string * float * float
val font-latin-italic : string * float * float
val font-latin-sans : string * float * float
val font-latin-mono : string * float * float
val font-cjk-mincho : string * float * float
val font-cjk-gothic : string * float * float
val set-latin-font : (string * float * float) -> context -> context
val set-cjk-font : (string * float * float) -> context -> context
direct \ref : [string] inline-cmd
direct \ref-page : [string] inline-cmd
direct \figure : [string?; inline-text; block-text] inline-cmd
direct +p : [inline-text] block-cmd
direct +pn : [inline-text] block-cmd
direct +section : [string?; string?; inline-text; block-text] block-cmd
direct +subsection : [string?; string?; inline-text; block-text] block-cmd
direct \emph : [inline-text] inline-cmd
direct \footnote : [inline-text] inline-cmd
end = struct
type toc-element =
| TOCElementSection of string * inline-text
| TOCElementSubsection of string * inline-text
let generate-fresh-label =
let-mutable count <- 0 in
(fun () -> (
let () = count <- !count + 1 in
`generated:` ^ (arabic (!count))
))
let no-pads = (0pt, 0pt, 0pt, 0pt)
let-inline ctx \ref key =
let opt = get-cross-reference (key ^ `:num`) in
let it =
match opt with
| None -> {?}
| Some(s) -> embed-string s
in
inline-frame-breakable no-pads (Annot.link-to-location-frame key None) (read-inline ctx it)
let-inline ctx \ref-page key =
let opt = get-cross-reference (key ^ `:page`) in
let it =
match opt with
| None -> {?}
| Some(s) -> embed-string s
in
inline-frame-breakable no-pads (Annot.link-to-location-frame key None) (read-inline ctx it)
let font-size-normal = 12pt
let font-size-title = 32pt
let font-size-author = 16pt
let font-size-section = 18pt
let font-size-subsection = 16pt
let section-top-margin = 20pt
let section-bottom-margin = 12pt
let section-top-padding = 6pt
let section-bottom-padding = 7pt
let section-line-sep = 4pt
let section-line-thickness1 = 2pt
let section-line-thickness2 = 1pt
let title-line-margin = 4pt
let title-line-thickness = 1pt
let header-line-thickness = 0.5pt
let header-line-margin-top = 2pt
let header-line-margin-bottom = 6pt
let font-ratio-latin = 1.
let font-ratio-cjk = 0.88
let font-latin-roman = (`Junicode` , font-ratio-latin, 0.)
let font-latin-bold = (`Junicode-b` , font-ratio-latin, 0.)
let font-latin-italic = (`Junicode-it`, font-ratio-latin, 0.)
let font-latin-sans = (`lmsans` , font-ratio-latin, 0.)
let font-latin-mono = (`lmmono` , font-ratio-latin, 0.)
let font-cjk-mincho = (`ipaexm` , font-ratio-cjk , 0.)
let font-cjk-gothic = (`ipaexg` , font-ratio-cjk , 0.)
let set-latin-font font ctx =
ctx |> set-font Latin font
let set-cjk-font font ctx =
ctx |> set-font HanIdeographic font
|> set-font Kana font
let get-standard-context wid =
get-initial-context wid (command \math)
|> set-code-text-command Code.(command \code)
|> set-dominant-wide-script Kana
|> set-language Kana Japanese
|> set-language HanIdeographic Japanese
|> set-dominant-narrow-script Latin
|> set-language Latin English
|> set-font Kana font-cjk-mincho
|> set-font HanIdeographic font-cjk-mincho
|> set-font Latin font-latin-roman
|> set-math-font `lmodern`
|> set-hyphen-penalty 100
let-mutable ref-float-boxes <- []
let height-of-float-boxes pageno =
% let () = display-message `get height` in
(!ref-float-boxes) |> List.fold-left (fun h (pn, bb) -> (
if pn < pageno then h +' (get-natural-length bb) else h
)) 0pt
let-mutable ref-figure <- 0
let-inline ctx \figure ?:labelopt caption inner =
let () = ref-figure <- !ref-figure + 1 in
let s-num = arabic (!ref-figure) in
let () =
match labelopt with
| Some(label) -> register-cross-reference (label ^ `:num`) s-num
| None -> ()
in
let it-num = embed-string s-num in
let ds =
match labelopt with
| Some(label) -> Annot.register-location-frame label
| None ->
let d (_, _) _ _ _ = [] in (d, d, d, d)
in
let bb-inner =
block-frame-breakable ctx (2pt, 2pt, 2pt, 2pt) ds (fun ctx -> (
read-block ctx inner
+++ line-break true true ctx (inline-fil ++ read-inline ctx {図#it-num; #caption;} ++ inline-fil)
))
in
hook-page-break (fun pbinfo _ -> (
% let () = display-message (`register` ^ (arabic pbinfo#page-number)) in
ref-float-boxes <- (pbinfo#page-number, bb-inner) :: !ref-float-boxes
))
let title-deco =
let pads = (5pt, 5pt, 10pt, 10pt) in
let deco (x, y) wid hgt dpt =
let path1 =
let cx = 14pt in
let cy = 8pt in
let xL = x in
let xR = x +' wid in
let yT = y +' hgt in
let yB = y -' dpt in
start-path (xL, yT)
|> line-to (xR, yT)
|> bezier-to (xR +' cx, yT -' cy) (xR +' cx, yB +' cy) (xR, yB)
|> line-to (xL, yB)
|> close-with-bezier (xL -' cx, yB +' cy) (xL -' cx, yT -' cy)
in
let path2 =
let cx = 12pt in
let cy = 8pt in
let gapx = 3pt in
let gapy = 5pt in
let xL = x +' gapx in
let xR = x +' wid -' gapx in
let yT = y +' hgt -' gapy in
let yB = y -' dpt +' gapy in
start-path (xL, yT)
|> line-to (xR, yT)
|> bezier-to (xR +' cx, yT -' cy) (xR +' cx, yB +' cy) (xR, yB)
|> line-to (xL, yB)
|> close-with-bezier (xL -' cx, yB +' cy) (xL -' cx, yT -' cy)
in
[
stroke 3pt Color.black path1;
stroke 1pt Color.black path2;
]
in
(deco, deco, deco, deco)
let-block ctx +make-title it-title it-author =
let pads = (20pt, 20pt, 10pt, 10pt) in
block-frame-breakable ctx pads title-deco (fun ctx -> (
let ctx-title =
ctx |> set-font-size font-size-title
|> set-font Latin font-latin-roman
in
let ctx-author =
ctx |> set-font-size font-size-author
|> set-font Latin font-latin-roman
in
let ib-title = read-inline ctx-title it-title in
let ib-line =
let thk = title-line-thickness in
let wid = get-text-width ctx in
let path (x, y) =
start-path (x, y +' thk *' 0.5)
|> line-to (x +' wid, y +' thk *' 0.5)
|> terminate-path
in
inline-graphics wid thk 0pt (fun pt -> (
[ stroke thk Color.black (path pt); ]
))
in
let ib-author = read-inline ctx-author it-author in
let bb-title =
% if get-text-width ctx <' get-natural-width ib-title then
% form-paragraph ctx-title (ib-title ++ inline-fil)
% else
form-paragraph (ctx-title |> set-paragraph-margin 12pt 0pt)
(inline-fil ++ ib-title ++ inline-fil)
in
let bb-line =
form-paragraph (ctx |> set-paragraph-margin title-line-margin title-line-margin)
(ib-line ++ inline-fil)
in
let bb-author = form-paragraph ctx-author (inline-fil ++ ib-author) in
bb-title +++ bb-line +++ bb-author
))
let make-section-title ctx =
ctx |> set-font-size font-size-section
|> set-font Latin font-latin-sans
|> set-cjk-font font-cjk-gothic
let make-subsection-title ctx =
ctx |> set-font-size font-size-subsection
|> set-font Latin font-latin-sans
|> set-cjk-font font-cjk-gothic
let-mutable toc-acc-ref <- []
let-mutable outline-ref <- []
let get-cross-reference-number label =
match get-cross-reference (label ^ `:num`) with
| None -> `?`
| Some(s) -> s
let get-cross-reference-page label =
match get-cross-reference (label ^ `:page`) with
| None -> `?`
| Some(s) -> s
let section-heading ctx ib-heading =
let wid = get-text-width ctx in
let h = section-line-sep in
let th1 = section-line-thickness1 in
let th2 = section-line-thickness2 in
let color = get-text-color ctx in
line-break true false (ctx |> set-paragraph-margin section-top-margin 0pt)
(inline-graphics wid h 0pt (fun (x, y) -> [
stroke th1 color (Gr.line (x, y +' h) (x +' wid, y +' h));
stroke th2 color (Gr.line (x, y) (x +' wid, y));
]))
+++
line-break false false (ctx |> set-paragraph-margin section-top-padding section-bottom-padding)
ib-heading
+++
line-break false false (ctx |> set-paragraph-margin 0pt section-bottom-margin)
(inline-graphics wid h 0pt (fun (x, y) -> [
stroke th2 color (Gr.line (x, y +' h) (x +' wid, y +' h));
stroke th1 color (Gr.line (x, y) (x +' wid, y));
]))
let-inline ctx \dummy it =
let ib = read-inline (ctx |> set-text-color Color.white) it in
let w = get-natural-width ib in
ib ++ inline-skip (0pt -' w)
let-rec repeat-inline n ib =
if n <= 0 then inline-nil else
ib ++ (repeat-inline (n - 1) ib)
let make-dots-line ctx w =
let ib = read-inline ctx {.} ++ inline-skip 1pt in
let wdot = get-natural-width ib in
let n = round (w /' wdot) in
inline-fil ++ (repeat-inline n ib)
let default-config =
(|
show-pages = true;
paper-size = A4Paper;
text-width = 440pt;
text-height = 630pt;
text-origin = (80pt, 100pt);
header-origin = (40pt, 30pt);
footer-origin = (40pt, 780pt);
header-width = 520pt;
footer-width = 520pt;
|)
let document record ?:configopt inner =
% -- mandatory designation --
let title = record#title in
let author = record#author in
% -- optional designation --
let config = Option.from default-config configopt in
let page = config#paper-size in
let txtorg = config#text-origin in
let txtwid = config#text-width in
let txthgt = config#text-height in
let hdrorg = config#header-origin in
let ftrorg = config#footer-origin in
let hdrwid = config#header-width in
let ftrwid = config#footer-width in
let show-pages = config#show-pages in
% -- constants --
let thickness = header-line-thickness in
let () =
register-cross-reference `changed` `F`
in
let ctx-doc = get-standard-context txtwid in
% -- title --
let bb-title =
if record#show-title then
read-block ctx-doc '<+make-title(title)(author);>
else
block-nil
in
% -- main --
let bb-main = read-block ctx-doc inner in
% -- table of contents --
let toc-subsection-indent = 20pt in
let bb-toc =
if not record#show-toc then
block-nil
else
let ib-toc-title =
read-inline (make-section-title ctx-doc) {目次} ++ inline-fil
in
let bb-toc-main =
(!toc-acc-ref) |> List.reverse |> List.fold-left (fun bbacc tocelem -> (
match tocelem with
| TOCElementSection(label, title) ->
let it-num = embed-string (get-cross-reference-number label) in
let it-page = embed-string (get-cross-reference-page label) in
let ib-title = read-inline ctx-doc {#it-num;. #title;} ++ inline-skip 3pt in
let ib-page = inline-skip 3pt ++ read-inline ctx-doc it-page in
let ib-middle =
let w = (get-text-width ctx-doc) -' (get-natural-width ib-title) -' (get-natural-width ib-page) in
if w <' 0pt then inline-fil else
make-dots-line ctx-doc w
in
bbacc +++ line-break true true ctx-doc
(inline-frame-breakable no-pads (Annot.link-to-location-frame label None) (ib-title ++ ib-middle ++ ib-page))
| TOCElementSubsection(label, title) ->
let it-num = embed-string (get-cross-reference-number label) in
let it-page = embed-string (get-cross-reference-page label) in
let ib-indent = inline-skip toc-subsection-indent in
let ib-title =
read-inline ctx-doc {#it-num;. #title;}
++ inline-skip 3pt
in
let ib-page = inline-skip 3pt ++ read-inline ctx-doc it-page in
let ib-middle =
let w = (get-text-width ctx-doc) -' (get-natural-width ib-indent)
-' (get-natural-width ib-title) -' (get-natural-width ib-page) in
if w <' 0pt then inline-fil else
make-dots-line ctx-doc w
in
bbacc +++ line-break true true ctx-doc
(ib-indent ++ (inline-frame-breakable no-pads (Annot.link-to-location-frame label None) (ib-title ++ ib-middle ++ ib-page)))
)) block-nil
in
(section-heading ctx-doc ib-toc-title) +++ bb-toc-main
in
% -- page settings --
let pagecontf pbinfo =
let () = FootnoteScheme.start-page () in
let hgtfb = height-of-float-boxes pbinfo#page-number in
let (txtorgx, txtorgy) = txtorg in
(|
text-origin = (txtorgx, txtorgy +' hgtfb);
text-height = txthgt -' hgtfb;
|)
in
let pagepartsf pbinfo =
let pageno = pbinfo#page-number in
let header =
let ctx =
get-standard-context hdrwid
|> set-paragraph-margin 0pt 0pt
in
let ib-text =
if pageno mod 2 == 0 then
(inline-fil ++ read-inline ctx title)
else
(read-inline ctx title ++ inline-fil)
in
% let () = display-message `insert` in
let (bb-float-boxes, acc) =
(!ref-float-boxes) |> List.fold-left (fun (bbacc, acc) elem -> (
let (pn, bb) = elem in
if pn < pageno then
let bbs =
line-break true true (ctx |> set-paragraph-margin 0pt 12pt)
(inline-fil ++ embed-block-top ctx txtwid (fun _ -> bb) ++ inline-fil)
% 'ctx' is a dummy context
in
(bbacc +++ bbs, acc)
else
(bbacc, elem :: acc)
)) (block-nil, [])
in
let () = ref-float-boxes <- acc in
line-break true true ctx ib-text
+++ line-break true true (ctx |> set-paragraph-margin header-line-margin-top header-line-margin-bottom)
((inline-graphics hdrwid thickness 0pt
(fun (x, y) -> [ fill Color.black (Gr.rectangle (x, y) (x +' hdrwid, y +' thickness))])) ++ inline-fil)
+++ bb-float-boxes
in
let footer =
if show-pages then
let ctx = get-standard-context ftrwid in
let it-pageno = embed-string (arabic pbinfo#page-number) in
line-break true true ctx
(inline-fil ++ (read-inline ctx {— #it-pageno; —}) ++ inline-fil)
else
block-nil
in
(|
header-origin = hdrorg;
header-content = header;
footer-origin = ftrorg;
footer-content = footer;
|)
in
let doc = page-break page pagecontf pagepartsf (bb-title +++ bb-toc +++ bb-main) in
let () = register-outline (List.reverse !outline-ref) in
doc
let-mutable needs-indentation-ref <- true
let-mutable num-section <- 0
let-mutable num-subsection <- 0
let quad-indent ctx =
inline-skip (get-font-size ctx)
let-block ctx +p inner =
let needs-indentation =
if !needs-indentation-ref then true else
let () = needs-indentation-ref <- true in
false
in
let ib-inner = read-inline ctx inner in
let br-parag =
if needs-indentation then
(quad-indent ctx) ++ ib-inner ++ inline-fil
else
ib-inner ++ inline-fil
in
form-paragraph ctx br-parag
let-block ctx +pn inner =
let () = needs-indentation-ref <- true in
let ib-inner = read-inline ctx inner in
form-paragraph ctx (ib-inner ++ inline-fil)
let section-scheme ctx label title outline-title-opt inner =
let ctx-title = make-section-title ctx in
let () = num-section <- !num-section + 1 in
let () = num-subsection <- 0 in
let () = needs-indentation-ref <- false in
let s-num = arabic (!num-section) in
let () = register-cross-reference (label ^ `:num`) s-num in
let () = toc-acc-ref <- (TOCElementSection(label, title)) :: !toc-acc-ref in
let ib-num =
read-inline ctx-title (embed-string (s-num ^ `.`))
++ hook-page-break (fun pbinfo _ -> register-cross-reference (label ^ `:page`) (arabic pbinfo#page-number))
in
let ib-title = read-inline ctx-title title in
let outline-title = Option.from (extract-string ib-title) outline-title-opt in
let () = outline-ref <- (0, s-num ^ `. `# ^ outline-title, label, false) :: !outline-ref in
let bb-title =
let ib =
inline-frame-breakable no-pads (Annot.register-location-frame label)
(ib-num ++ (inline-skip 10pt) ++ ib-title ++ (inline-fil))
in
section-heading ctx ib
in
let bb-inner = read-block ctx inner in
bb-title +++ bb-inner
let subsection-scheme ctx label title outline-title-opt inner =
let () = num-subsection <- !num-subsection + 1 in
let () = needs-indentation-ref <- false in
let s-num = arabic (!num-section) ^ `.` ^ arabic (!num-subsection) in
let () = register-cross-reference (label ^ `:num`) s-num in
let () = toc-acc-ref <- (TOCElementSubsection(label, title)) :: !toc-acc-ref in
let ctx-title = make-subsection-title ctx in
let ib-num =
read-inline ctx-title (embed-string (s-num ^ `.`))
++ hook-page-break (fun pbinfo _ -> register-cross-reference (label ^ `:page`) (arabic pbinfo#page-number))
in
let ib-title = read-inline ctx-title title in
let outline-title = Option.from (extract-string ib-title) outline-title-opt in
let () = outline-ref <- (1, s-num ^ `. `# ^ outline-title, label, false) :: !outline-ref in
let bb-title =
line-break true false (ctx |> set-paragraph-margin section-top-margin section-bottom-margin)
(inline-frame-breakable no-pads (Annot.register-location-frame label)
(ib-num ++ (inline-skip 10pt) ++ ib-title ++ (inline-fil)))
in
let bb-inner = read-block ctx inner in
bb-title +++ bb-inner
let-block ctx +section ?:labelopt ?:outline-title-opt title inner =
let label =
match labelopt with
| None -> generate-fresh-label ()
| Some(label) -> label
in
section-scheme ctx label title outline-title-opt inner
let-block ctx +subsection ?:labelopt ?:outline-title-opt title inner =
let label =
match labelopt with
| None -> generate-fresh-label ()
| Some(label) -> label
in
subsection-scheme ctx label title outline-title-opt inner
let-inline ctx \emph inner =
let ctx-emph =
ctx |> set-font Latin font-latin-italic
|> set-cjk-font font-cjk-gothic
|> set-text-color (CMYK(1., 0., 0., 0.))
in
read-inline ctx-emph inner
let-inline ctx \footnote it =
let size = get-font-size ctx in
let ibf num =
let it-num = embed-string (arabic num) in
let ctx =
ctx |> set-font-size (size *' 0.75)
|> set-manual-rising (size *' 0.25)
in
read-inline ctx {\*#it-num;}
in
let bbf num =
let it-num = embed-string (arabic num) in
let ctx =
ctx |> set-font-size (size *' 0.9)
|> set-leading (size *' 1.2)
|> set-paragraph-margin (size *' 0.5) (size *' 0.5)
%temporary
in
line-break false false ctx (read-inline ctx {#it-num; #it;} ++ inline-fil)
in
FootnoteScheme.main ctx ibf bbf
end
let document = StdJaBook.document
% ad-hoc