OCaml Forge

Browse | Submit A New Snippet | Create A Package

Aperiodic Tilings

Type:
Full Script
Category:
Other
License:
BSD License
Language:
Other Language
 
Description:
Program to generate aperiodic tilings given by rules encoded in modules.

Versions Of This Snippet:

Snippet ID Download Version Date Posted Author Delete
41.0.12008-08-18 01:24Matías Giovannini

Download a raw-text version of this code by clicking on "Download Version"

 


Latest Snippet Version: 1.0.1

(* * A program to draw aperiodic tilings. * * Copyright (c) 2008, Matias Giovannini. * * Permission is granted to use this program without restrictions, * except the above copyright notice must be preserved. * * For a description of the program, see * http://alaska-kamtchatka.blogspot.com/2008/08/aperiodic-tilings.html * * It will only work on Mac OS X as-is. * * Save it to tiling.ml, and compile it with * ocamlopt -o tiling tiling.ml *) module type MONAD = sig type 'a m val return : 'a -> 'a m val bind : 'a m -> ('a -> 'b m) -> 'b m end (* return a >>= k == k a m >>= return == m m >>= (fun x -> k x >>= h) == (m >>= k) >>= h *) module Monad (M : MONAD) = struct include M let seq m f = bind m (fun _ -> f) let join m = bind m (fun m -> m) let fmap f m = bind m (fun x -> return (f x)) let liftm = fmap let liftm2 f m m' = bind m (fun x -> bind m' (fun y -> return (f x y))) let liftm3 f m m' m'' = bind m (fun x -> bind m' (fun y -> bind m'' (fun z -> return (f x y z)))) let mapm f l = List.fold_right (liftm2 (fun x xs -> f x :: xs)) l (return []) let sequence l = mapm (fun x -> x) l let mapm_ f l = List.fold_right (fun x -> seq (f x)) l (return ()) let sequence_ l = mapm_ (fun x -> x) l module Op = struct let ( >>= ) = bind let ( >> ) = seq end end module ListM = struct type 'a m = 'a list let return x = [x] let bind l f = List.concat (List.map f l) end module State (S : sig type t end) = struct type 'a m = St of (S.t -> 'a * S.t) let return a = St (fun s -> (a, s)) let bind (St m) f = St (fun s -> let (x, s') = m s in let (St m') = f x in m' s') let get = St (fun s -> (s, s)) let put = fun s -> St (fun _ -> ((), s)) let eval (St m) = fun s -> fst (m s) let run (St m) = fun s -> snd (m s) end module Out = struct type 'a m = Out of (out_channel -> 'a) let return a = Out (fun _ -> a) let bind (Out m) f = Out (fun out -> let x = m out in let (Out m') = f x in m' out) let fmt fmt = let ship s = Out (fun out -> output_string out s; output_char out '\n') in Printf.kprintf ship fmt let write name (Out m) = let out = open_out_bin name in try let x = m out in close_out out; x with e -> close_out out; raise e end type point = float * float type rgbcolor = float * float * float module type GRAP = sig module M : MONAD type t = unit M.m val weight : float -> t val gray : float -> t val color : rgbcolor -> t val save : t -> t val dot : point -> t val line : point -> point -> t val rect : ?fill:bool -> point -> point -> t val poly : ?fill: bool -> point list -> t end let mm = ( *. ) (72. /. 25.4) module Eps = struct module M = Monad(Out) type t = unit M.m open Out open M.Op let iso_time () = let tm = Unix.gmtime (Unix.time ()) in Printf.sprintf "%04d%02d%02dT%02d%02d%02d" (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec let eps margin width height drawing = let app_name = Filename.basename Sys.executable_name in fmt "%%!PS-Adobe-3.0 EPSF-3.0" >> fmt "%%%%BoundingBox: 0 0 %d %d" (truncate (ceil (width +. 2. *. margin))) (truncate (ceil (height +. 2. *. margin))) >> fmt "%%%%Creator: %s" app_name >> fmt "%%%%CreationDate: %s" (iso_time ()) >> fmt "%%%%DocumentData: Clean7Bit" >> fmt "%%%%EndComments" >> drawing >> fmt "showpage" >> fmt "%%%%EOF" let show ?(margin=0.) width height f = let name = Filename.temp_file "grap" ".eps" in write name (eps margin width height f); ignore (Unix.system (Printf.sprintf "/usr/bin/open %s" name)) let weight w = fmt "%g setlinewidth" w and gray w = fmt "%g setgray" w and color (r, g, b) = fmt "%g %g %g setrgbcolor" r g b let save f = fmt "gsave" >> f >> fmt "grestore" let moveto (x, y) = fmt "%g %g moveto" x y let lineto (x, y) = fmt "%g %g lineto" x y let path f = fmt "newpath" >> f >> fmt "closepath" let draw = fmt "stroke" let paint = fmt "fill" let dot (x, y) = path (fmt "%g %g currentlinewidth 1.5 mul 0 360 arc" x y) >> paint let line p q = fmt "newpath" >> moveto p >> lineto q >> draw let rect ?(fill=false) (x, y) (x', y') = let w, h = x' -. x, y' -. y in fmt "%g %g %g %g rect%s" x y w h (if fill then "fill" else "stroke") let polyline closing l = match l with | [] -> return () | p :: ps -> path (moveto p >> M.mapm_ lineto ps) >> closing let poly ?(fill=false) = polyline (if fill then paint else draw) end (* let () = let module M = struct open Eps open Eps.M.Op let draw p = show 100. 100. (poly p >> (M.mapm_ dot (List.tl p))) end in M.draw (List.map (fun i -> let a = float i *. 2. *. pi /. 10. in let c, s = cos a, sin a in (50. +. 20. *. c, 50. +. 20. *. s) ) (iota 11)) *) module Bounds = struct type bounds = { top : float; left : float; bottom : float; right : float; } let empty = { top = infinity; left = infinity; bottom = neg_infinity; right = neg_infinity; } let add b (x, y) = { top = min y b.top; left = min x b.left; bottom = max y b.bottom; right = max x b.right; } module St = State(struct type t = bounds end) module M = Monad(St) type t = unit M.m open M.Op let nop = M.return () and draw p = St.get >>= fun b -> St.put (add b p) let bounds f = St.run f empty let weight _ = nop and gray _ = nop and color _ = nop and save f = f and dot p = draw p and line p q = draw p >> draw q and rect ?fill p q = draw p >> draw q and poly ?fill l = M.mapm_ draw l end (* let b = let module M = struct open Bounds open Bounds.M.Op let draw p = bounds (poly p >> (M.mapm_ dot (List.tl p))) end in M.draw (List.map (fun i -> let a = float i *. 2. *. pi /. 10. in let c, s = cos a, sin a in (50. +. 20. *. c, 50. +. 20. *. s) ) (iota 11)) *) type xform = float array let identity = [| 1.; 0.; 0.; 0.; 1.; 0. |] and fliph = [| 1.; 0.; 0.; 0.; -1.; 0. |] and flipv = [| -1.; 0.; 0.; 0.; 1.; 0. |] and reflect = [| -1.; 0.; 0.; 0.; -1.; 0. |] and qrot = [| 0.; -1.; 0.; 1.; 0.; 0. |] let scale s = [| s; 0.; 0.; 0.; s; 0. |] and translate (x, y : point) = [| 1.; 0.; x; 0.; 1.; y |] and skew (x, y : point) = [| 1.; x; 0.; y; 1.; 0. |] and rotate a = let s, c = sin a, cos a in [| c; -. s; 0.; s; c; 0. |] let ( % ) (t : xform) (u : xform) : xform = [| t.(0) *. u.(0) +. t.(3) *. u.(1); t.(1) *. u.(0) +. t.(4) *. u.(1); t.(2) *. u.(0) +. t.(5) *. u.(1) +. u.(2); t.(0) *. u.(3) +. t.(3) *. u.(4); t.(1) *. u.(3) +. t.(4) *. u.(4); t.(2) *. u.(3) +. t.(5) *. u.(4) +. u.(5); |] let apply (t : xform) (x, y : point) : point = (x *. t.(0) +. y *. t.(1) +. t.(2), x *. t.(3) +. y *. t.(4) +. t.(5)) let pi = 3.141592653589793238462643383276 let deg x = x *. 0.017453292519943295769236907684 let rad x = x *. 57.295779513082320876798154814169 module type TILING = sig type t val name : string val shape : t -> point list val color : t -> rgbcolor val seed : (t * xform) list val rules : (t * xform) -> (t * xform) list end let iterate f l n = let rec go l n = if n == 0 then l else go (List.concat (List.map f l)) (pred n) in go l n module Generator (S : TILING) = struct module Tiling (G : GRAP) = struct module M = Monad(G.M) open M.Op let draw = M.mapm_ (fun (t, x) -> let vs = List.map (apply x) (S.shape t) in G.color (S.color t) >> G.poly ~fill:true vs >> G.gray 0. >> G.poly ~fill:false vs) end let bounds tiling = let module T = Tiling(Bounds) in Bounds.bounds (T.draw tiling) let show width height tiling = let module T = Tiling(Eps) in Eps.show width height (T.M.seq (Eps.weight 0.5) (T.draw tiling)) let transform x' = List.map (fun (t, x) -> (t, x % x')) let generate dim levels = let tiling = iterate S.rules S.seed levels in let bbox = bounds tiling in let width = bbox.Bounds.right -. bbox.Bounds.left and height = bbox.Bounds.bottom -. bbox.Bounds.top in let size = dim /. width in let xform = translate (-. bbox.Bounds.left, -. bbox.Bounds.top) % scale size in show (width *. size) (height *. size) (transform xform tiling) (* let generate dim levels = let bbox = bounds S.seed in let width = bbox.Bounds.right -. bbox.Bounds.left and height = bbox.Bounds.bottom -. bbox.Bounds.top in let size = dim /. width in let xform = translate (-. bbox.Bounds.left, -. bbox.Bounds.top) % scale size in let tiling = iterate S.rules (transform xform S.seed) levels in show (width *. size) (height *. size) tiling *) end module AmmanBeenkerRhombTriangle : TILING = struct (* http://tilings.math.uni-bielefeld.de/substitution_rules/ammann_beenker_rhomb_triangle *) type t = Tu | Td | Pa let name = "Amman-Beenker" let rho = sqrt 2. and rho' = sqrt 0.5 let shape = function | Tu -> [0., 0.; rho', rho'; rho, 0.; 0., 0.] | Td -> [0., 0.; rho, 0.; rho', -. rho'; 0., 0.] | Pa -> [0., 0.; 1., 0.; 1. +. rho', -. rho'; rho', -. rho'; 0., 0.] let color = function | Tu -> (0.976, 0.4, 0.063) | Td -> (0.973, 0.796, 0.4) | Pa -> (0.804, 0.796, 0.855) let seed = let xform = rotate (deg 45.) in [Tu, xform; Td, xform] let rules (t, x) = let x' = scale (rho -. 1.) % x in match t with | Tu -> [ Tu, rotate (deg (-135.)) % translate (1., 1.) % x'; Pa, rotate (deg (-90.)) % translate (1. +. rho', 1. +. rho') % x'; Tu, rotate (deg 135.) % translate (2. +. rho', rho') % x'; Pa, rotate (deg 0.) % translate (1. +. rho', rho') % x'; Td, rotate (deg 180.) % translate (1. +. rho, 0.) % x'; ] | Td -> [ Td, rotate (deg 135.) % translate (1., -1.) % x'; Pa, rotate (deg 135.) % translate (1. +. rho', -1. -. rho') % x'; Td, rotate (deg (-135.)) % translate (2. +. rho', -. rho') % x'; Pa, rotate (deg 45.) % translate (1. +. rho', -. rho') % x'; Tu, rotate (deg 180.) % translate (1. +. rho, 0.) % x'; ] | Pa -> [ Pa, x'; Td, rotate (deg 0.) % translate (1., 0.) % x'; Tu, rotate (deg 135.) % translate (2. +. rho, -1.) % x'; Pa, rotate (deg 0.) % translate (1. +. rho, -1.) % x'; Td, rotate (deg 180.) % translate (1. +. rho +. rho', -1. -. rho') % x'; Tu, rotate (deg (-45.)) % translate (rho', -. rho') % x'; Pa, rotate (deg (-90.)) % translate (1. +. rho, 0.) % x'; ] end module Pythagoras32 : TILING = struct (* http://tilings.math.uni-bielefeld.de/substitution_rules/pythagoras_3_2 *) type t = T0 | T1 | T2 let name = "Pythagoras-3-2" let rho = sqrt 2. and rho' = sqrt 0.5 and tau = sqrt 3. let shape = function | T0 | T1 | T2 -> [0., 0.; 1., 0.; 1., rho; 0., 0.] let color = function | T0 -> (1., 1., 0.) | T1 -> (1., 0.6, 0.) | T2 -> (1., 0.2, 0.) let seed = [T0, identity; T0, reflect % translate (1., rho)] let alpha = 0.9553166181245092781638571 let rules (t, x) = match t with | T0 -> [ T1, x ] | T1 -> [ T2, x ] | T2 -> [ T0, flipv % rotate (alpha -. pi) % scale (1. /. tau) % x; T2, flipv % rotate (alpha -. 0.5 *. pi) % scale (rho /. tau) % translate (1., 0.) % x; ] end module PenroseRhomb : TILING = struct (* http://tilings.math.uni-bielefeld.de/substitution_rules/penrose_rhomb *) type t = R0 | R1 let name = "Penrose.Rhomb" let phi = 0.25 *. (sqrt 5. +. 1.) let phi' = 0.25 *. (sqrt 5. -. 1.) and eta = sqrt (0.125 *. (5. +. sqrt 5.)) and eta' = sqrt (0.125 *. (5. -. sqrt 5.)) let shape = function | R0 -> [0., 0.; eta', -. phi ; 0., -2. *. phi ; -. eta', -. phi ; 0., 0.] | R1 -> [0., 0.; eta , -. phi'; 0., -2. *. phi'; -. eta , -. phi'; 0., 0.] let color = function | R0 -> (0.973, 0.796, 0.4) | R1 -> (0.08, 0.027, 0.4) let seed = [ R0, identity; R0, rotate (deg 72.); R0, rotate (deg 144.); R0, rotate (deg 216.); R0, rotate (deg 288.); ] let rules (t, x) = let x' = scale (2. *. phi') % x in match t with | R0 -> [ R0, reflect % translate (0., -2. *. phi) % x'; R1, rotate (deg 36.) % translate (eta', -. phi) % x'; R0, rotate (deg 144.) % translate (0., -1. -. 2. *. phi) % x'; R0, rotate (deg (-144.)) % translate (0., -1. -. 2. *. phi) % x'; R1, rotate (deg (-36.)) % translate (-. eta', -. phi) % x'; ] | R1 -> [ R1, rotate (deg 108.) % translate (-. eta', phi' -. 0.5) % x'; R1, rotate (deg (-108.)) % translate (eta', phi' -. 0.5) % x'; R0, rotate (deg 108.) % translate (0., -1.) % x'; R0, rotate (deg (-108.)) % translate (0., -1.) % x'; ] end module RobinsonTriangle : TILING = struct (* http://tilings.math.uni-bielefeld.de/substitution_rules/robinson_triangle *) type t = Su | Sd | Au | Ad let name = "Robinson.Triangle" let phi = 0.25 *. (sqrt 5. +. 1.) let phi' = 0.25 *. (sqrt 5. -. 1.) and eta = sqrt (0.125 *. (5. +. sqrt 5.)) and eta' = sqrt (0.125 *. (5. -. sqrt 5.)) let shape = function | Su -> [0., 0.; 2. *. phi , 0.; phi , eta'; 0., 0.] | Sd -> [0., 0.; 2. *. phi , 0.; phi , -. eta'; 0., 0.] | Au -> [0., 0.; 2. *. phi', 0.; phi', eta ; 0., 0.] | Ad -> [0., 0.; 2. *. phi', 0.; phi', -. eta ; 0., 0.] let color = function | Su -> (0., 0., 0.376) | Sd -> (0.808, 0.796, 0.89) | Au -> (1., 0.8, 0.4) | Ad -> (1., 0.4, 0.) let seed = let t = rotate (deg 36.) in [ Su, t; Sd, t ] let rules (t, x) = let x' = scale (0.5 /. phi) % x in match t with | Su -> [ Su, rotate (deg (-144.)) % translate (0.5 +. phi, eta) % x'; Ad, rotate (deg ( -36.)) % translate (0.5 +. phi, eta) % x'; Sd, reflect % translate (1. +. 2. *. phi, 0.) % x'; ] | Sd -> [ Sd, rotate (deg 144.) % translate (0.5 +. phi, -. eta) % x'; Au, rotate (deg 36.) % translate (0.5 +. phi, -. eta) % x'; Su, reflect % translate (1. +. 2. *. phi, 0.) % x'; ] | Au -> [ Au, rotate (deg 108.) % translate (1., 0.) % x'; Su, rotate (deg (-108.)) % translate (0.5, 2. *. eta *. phi) % x'; ] | Ad -> [ Ad, rotate (deg (-108.)) % translate (1., 0.) % x'; Sd, rotate (deg 108.) % translate (0.5, -2. *. eta *. phi) % x'; ] end (* http://tilings.math.uni-bielefeld.de/substitution_rules/trihex http://tilings.math.uni-bielefeld.de/substitution_rules/watanabe_ito_soma_8_fold http://tilings.math.uni-bielefeld.de/substitution_rules/ammann_beenker http://tilings.math.uni-bielefeld.de/substitution_rules/penrose_kite_dart *) let () = let module G = Generator(PenroseRhomb) in G.generate 256. 4

Submit a new version

You can submit a new version of this snippet if you have modified it and you feel it is appropriate to share with others..