Created
December 20, 2018 22:30
-
-
Save zr-tex8r/d6151fdf0ff705001f638e1b55eb9a58 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
% affsnowman.satyh: Affine-transformed snowman pictures | |
% | |
% Copyright (c) 2018 Takayuki YATO (aka. "ZR") | |
% GitHub: https:%github.com/zr-tex8r | |
% Twitter: @zr_tex8r | |
% Distributed under the MIT License. | |
@require: pervasives | |
@require: list | |
%=========================================================== module ZGr0 | |
module ZGr : sig | |
type matrix | |
val identity : matrix | |
val scale : float * float -> matrix | |
val translate : length * length -> matrix | |
val matrix : float * float * float * float * length * length -> matrix | |
type z-pre-path | |
val path-of : z-pre-path -> pre-path | |
val path : matrix -> point -> z-pre-path | |
val line-to : point -> z-pre-path -> z-pre-path | |
val curve-to : point -> point -> point -> z-pre-path -> z-pre-path | |
val close : z-pre-path -> path | |
val line-close : z-pre-path -> path | |
val curve-close : point -> point -> z-pre-path -> path | |
val lines-to : point list -> z-pre-path -> z-pre-path | |
val curves-to : (point * point * point) list -> z-pre-path -> z-pre-path | |
val ellipse : matrix -> point -> (length * length) -> path | |
val circle : matrix -> point -> length -> path | |
type canvas | |
val make-canvas : length -> length -> length -> matrix -> canvas | |
val c-path : canvas -> point -> z-pre-path | |
val c-ellipse : canvas -> point -> (length * length) -> path | |
val c-circle : canvas -> point -> length -> path | |
val fill : color -> path -> canvas -> canvas | |
val stroke : length -> color -> path -> canvas -> canvas | |
val fill-stroke : color -> length -> color -> path -> canvas -> canvas | |
val inline-canvas : canvas -> inline-boxes | |
end = struct | |
type matrix = float * float * float * float * length * length | |
let identity = (1., 0., 0., 1., 0pt, 0pt) | |
let scale (sx, sy) = (sx, 0., 0., sy, 0pt, 0pt) | |
let translate (tx, ty) = (1., 0., 0., 1., tx, ty) | |
let matrix mtx = mtx | |
let trans (a, b, c, d, e, f) (x, y) = | |
(x *' a +' y *' c +' e, x *' b +' y *' d +' f) | |
type z-pre-path = pre-path * matrix | |
let path-of (pth, _) = pth | |
let prim-line-to = line-to | |
let path mtx p = | |
(start-path (trans mtx p), mtx) | |
let line-to p (pth, mtx) = | |
(pth |> prim-line-to (trans mtx p), mtx) | |
let curve-to p1 p2 p3 (pth, mtx) = | |
(pth |> bezier-to (trans mtx p1) (trans mtx p2) (trans mtx p3), mtx) | |
let close (pth, _) = | |
terminate-path pth | |
let line-close (pth, _) = | |
close-with-line pth | |
let curve-close p1 p2 (pth, mtx) = | |
close-with-bezier (trans mtx p1) (trans mtx p2) pth | |
let lines-to ps zpth = | |
List.fold-left (fun zpth p -> zpth |> line-to p) zpth ps | |
let curves-to crvs zpth = | |
List.fold-left (fun zpth (p1, p2, p3) -> zpth |> curve-to p1 p2 p3) zpth crvs | |
let alpha = 0.55228475 | |
let ellipse mtx (cx, cy) (rx, ry) = | |
let (ax, ay) = (rx *' alpha, ry *' alpha) in | |
path mtx (cx +' rx, cy) | |
|> curve-to (cx +' rx, cy +' ay) (cx +' ax, cy +' ry) (cx, cy +' ry) | |
|> curve-to (cx -' ax, cy +' ry) (cx -' rx, cy +' ay) (cx -' rx, cy) | |
|> curve-to (cx -' rx, cy -' ay) (cx -' ax, cy -' ry) (cx, cy -' ry) | |
|> curve-close (cx +' ax, cy -' ry) (cx +' rx, cy -' ay) | |
let circle mtx ctr rds = | |
ellipse mtx ctr (rds, rds) | |
type metrics = length * length * length | |
type canvas = metrics * matrix * (graphics list) | |
let make-canvas wd ht dp mtx = | |
((wd, ht, dp), mtx, []) | |
let c-path (_, mtx, _) = | |
path mtx | |
let c-ellipse (_, mtx, _) = | |
ellipse mtx | |
let c-circle (_, mtx, _) = | |
circle mtx | |
let fill clr pth (mtr, mtx, gs) = | |
(mtr, mtx, (fill clr pth) :: gs) | |
let stroke lwd clr pth (mtr, mtx, gs) = | |
(mtr, mtx, (stroke lwd clr pth) :: gs) | |
let fill-stroke fclr lwd sclr pth cvs = | |
cvs |> fill fclr pth |> stroke lwd sclr pth | |
let inline-canvas ((wd, ht, dp), mtx, gs) = | |
let gs1 = List.reverse gs in | |
inline-graphics wd ht dp (fun p -> List.map (shift-graphics p) gs1) | |
end | |
%=========================================================== module Essential0 | |
module Essential : sig | |
direct \essential : [float * float] inline-cmd | |
end = struct | |
let base = RGB(0.000, 0.000, 0.000) | |
let muffler = RGB(0.855, 0.000, 0.000) | |
let arms = RGB(0.545, 0.188, 0.180) | |
let buttons = RGB(0.278, 0.498, 0.118) | |
let broom = RGB(0.655, 0.529, 0.141) | |
let line-width = 0.0139 | |
let descent = 0.08 | |
let strokes lwd clr lins cvs = | |
let prc cvs (p1, p2) = cvs |> | |
ZGr.stroke lwd clr (ZGr.c-path cvs p1 |> ZGr.line-to p2 |> ZGr.close) in | |
List.fold-left prc cvs lins | |
let make-trans siz (ax, ay) = | |
let scl = siz /' 1pt in | |
ZGr.matrix (scl, 0., scl *. ax, scl *. (1. +. ay), 0pt, 0pt) | |
let draw-essential siz (ax, ay) = | |
let lwd = siz *' line-width in | |
let (ht, dp) = (siz *' (1. -. descent), siz *' descent) in | |
let scl = siz /' 1pt in | |
let cvs = ZGr.make-canvas siz ht dp (make-trans siz (ax, ay)) in | |
let (path, ellipse) = (ZGr.c-path cvs, ZGr.c-ellipse cvs) in | |
cvs | |
% body | |
|> ZGr.stroke lwd base (path (0.50pt,0.72pt) |> ZGr.curves-to [ | |
((0.64pt,0.72pt), (0.76pt,0.65pt), (0.76pt,0.55pt)); | |
((0.76pt,0.51pt), (0.72pt,0.47pt), (0.67pt,0.44pt)); | |
((0.79pt,0.41pt), (0.84pt,0.32pt), (0.84pt,0.25pt)); | |
((0.84pt,0.13pt), (0.75pt,0.08pt), (0.68pt,0.08pt)); | |
((0.50pt,0.08pt), (0.40pt,0.08pt), (0.32pt,0.08pt)); | |
((0.25pt,0.08pt), (0.16pt,0.13pt), (0.16pt,0.25pt)); | |
((0.16pt,0.32pt), (0.21pt,0.41pt), (0.33pt,0.44pt)); | |
((0.28pt,0.47pt), (0.24pt,0.51pt), (0.24pt,0.55pt)); | |
] |> ZGr.curve-close (0.24pt,0.65pt) (0.36pt,0.72pt)) | |
% eyes | |
|> ZGr.fill base (ellipse (0.40pt,0.56pt) (0.02pt,0.03pt)) | |
|> ZGr.fill base (ellipse (0.60pt,0.56pt) (0.02pt,0.03pt)) | |
% mouth | |
|> ZGr.stroke lwd base (path (0.40pt,0.48pt) | |
|> ZGr.curve-to (0.45pt,0.45pt) (0.55pt,0.45pt) (0.60pt,0.48pt) | |
|> ZGr.close) | |
% broom | |
|> strokes (lwd *' 3.2) broom [((0.03pt,0.06pt), (0.12pt,0.50pt))] | |
|> strokes (lwd *' 1.2) broom [ | |
((0.11pt,0.50pt), (0.06pt,0.75pt)); | |
((0.12pt,0.50pt), (0.12pt,0.72pt)); | |
((0.12pt,0.50pt), (0.18pt,0.76pt)); | |
((0.12pt,0.50pt), (0.21pt,0.70pt)); | |
((0.13pt,0.50pt), (0.27pt,0.74pt))] | |
% arms | |
|> ZGr.fill-stroke arms lwd arms (path (0.20pt,0.31pt) |> ZGr.curves-to [ | |
((0.19pt,0.33pt), (0.14pt,0.41pt), (0.13pt,0.42pt)); | |
((0.12pt,0.43pt), (0.10pt,0.43pt), (0.07pt,0.44pt)); | |
((0.04pt,0.46pt), (0.06pt,0.46pt), (0.08pt,0.46pt)); | |
((0.09pt,0.46pt), (0.11pt,0.44pt), (0.12pt,0.44pt)); | |
((0.14pt,0.46pt), (0.14pt,0.47pt), (0.15pt,0.49pt)); | |
((0.16pt,0.51pt), (0.16pt,0.49pt), (0.16pt,0.48pt)); | |
((0.16pt,0.46pt), (0.14pt,0.44pt), (0.15pt,0.43pt)); | |
((0.16pt,0.42pt), (0.21pt,0.35pt), (0.22pt,0.33pt)); | |
] |> ZGr.curve-close (0.23pt,0.31pt) (0.21pt,0.30pt)) | |
|> ZGr.fill-stroke arms lwd arms (path (0.80pt,0.31pt) |> ZGr.curves-to [ | |
((0.81pt,0.33pt), (0.86pt,0.41pt), (0.87pt,0.42pt)); | |
((0.88pt,0.43pt), (0.90pt,0.43pt), (0.93pt,0.44pt)); | |
((0.96pt,0.46pt), (0.94pt,0.46pt), (0.92pt,0.46pt)); | |
((0.91pt,0.46pt), (0.89pt,0.44pt), (0.88pt,0.44pt)); | |
((0.86pt,0.46pt), (0.86pt,0.47pt), (0.85pt,0.49pt)); | |
((0.84pt,0.51pt), (0.84pt,0.49pt), (0.84pt,0.48pt)); | |
((0.84pt,0.46pt), (0.86pt,0.44pt), (0.85pt,0.43pt)); | |
((0.84pt,0.42pt), (0.79pt,0.35pt), (0.78pt,0.33pt)); | |
] |> ZGr.curve-close (0.77pt,0.31pt) (0.79pt,0.30pt)) | |
% buttons | |
|> ZGr.fill-stroke buttons lwd buttons | |
(ellipse (0.50pt,0.16pt) (0.03pt,0.03pt)) | |
|> ZGr.fill-stroke buttons lwd buttons | |
(ellipse (0.50pt,0.26pt) (0.03pt,0.03pt)) | |
% muffler | |
|> ZGr.fill-stroke muffler lwd muffler (path (0.27pt,0.48pt) |> ZGr.curves-to [ | |
((0.42pt,0.38pt), (0.58pt,0.38pt), (0.73pt,0.48pt)); | |
((0.75pt,0.46pt), (0.76pt,0.44pt), (0.77pt,0.41pt)); | |
((0.77pt,0.39pt), (0.75pt,0.37pt), (0.73pt,0.36pt)); | |
((0.74pt,0.33pt), (0.74pt,0.31pt), (0.76pt,0.26pt)); | |
((0.75pt,0.25pt), (0.72pt,0.24pt), (0.66pt,0.23pt)); | |
((0.66pt,0.27pt), (0.65pt,0.30pt), (0.63pt,0.34pt)); | |
((0.42pt,0.30pt), (0.32pt,0.35pt), (0.24pt,0.41pt)); | |
] |> ZGr.curve-close (0.25pt,0.45pt) (0.26pt,0.47pt)) | |
let-inline ctx \essential (ax, ay) = | |
let siz = (get-font-size ctx) *' 0.8 in | |
ZGr.inline-canvas (draw-essential siz (ax, ay)) | |
end | |
%=========================================================== all done | |
%% EOF |
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 | |
@import: affsnowman | |
let-inline ctx \fsz sz it = | |
let c = set-font-size sz ctx in | |
read-inline c it | |
in | |
document (| | |
title = {\essential((0.0, 0.0));}; | |
author = {}; | |
show-title = true; | |
show-toc = false; | |
|) '< | |
+p{ | |
\fsz(40pt){ | |
\essential((0.0, 0.0)); | |
\essential((0.2, 0.1)); | |
\essential((0.4, 0.2)); | |
\essential((0.1, 0.1)); | |
\essential((0.0, 0.0)); | |
\essential((0.2, 0.1)); | |
\essential((0.4, 0.2)); | |
\essential((0.1, 0.1)); | |
\essential((0.0, 0.0)); | |
} | |
} | |
> |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
もしかして: