Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
SATySFiで非△
% 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
@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
You can’t perform that action at this time.