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
|
(**************************************************************************)
(* *)
(* Copyright (C) Johannes Kanig, Stephane Lescuyer *)
(* Jean-Christophe Filliatre, Romain Bardou and Francois Bobot *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
open MetaPath
open Types
include MetaPath.BaseDefs
let start x = of_metapath (start x)
let append ?style x y =
of_metapath (append ?style (of_path x) (of_path y))
type t = Types.path
type metapath = Types.metapath
let knotp ?(l=defaultdir) ?(r=defaultdir) p = Types.mkKnot l p r
let knot ?(l) ?(r) ?(scale) p = knotp ?l (S.p ?scale p) ?r
let knotn ?(l) ?(r) p = knotp ?l (S.pt p) ?r
let knotlist = List.map (fun (x,y,z) -> Types.mkKnot x y z)
let cycle_tmp ?(dir=defaultdir) ?(style=defaultjoint) p = mkPACycle dir style p
let cycle = cycle_tmp
let concat ?style x y = of_metapath (concat ?style (of_path x) y)
(* construct a path with a given style from a knot list *)
let pathk ?(style) ?(cycle) l =
let p = MetaPath.pathk ?style l
in
match cycle with
| None -> of_metapath p
| Some style -> metacycle defaultdir style p
let pathp ?(style) ?(cycle) l =
pathk ?style ?cycle
(List.map (knotp) l)
let pathn ?(style) ?(cycle) l = pathp ?style ?cycle (List.map (Point.pt) l)
let path ?(style) ?(cycle) ?(scale) l =
let sc = S.ptlist ?scale in pathp ?style ?cycle (sc l)
(* construct a path with knot list and joint list *)
let jointpathk lp lj =
of_metapath (MetaPath.jointpathk lp lj)
let jointpathp lp lj = jointpathk (List.map (knotp) lp) lj
let jointpathn lp lj = jointpathk (List.map knotn lp) lj
let jointpath ?(scale) lp lj = jointpathk (List.map (knot ?scale) lp) lj
let scale f p = transform [Transform.scaled f] p
let rotate f p = transform [Transform.rotated f] p
let shift pt p = transform [Transform.shifted pt] p
let yscale n p = transform [Transform.yscaled n] p
let xscale n p = transform [Transform.xscaled n] p
let strip n p =
let p0 = point 0. p in
let p1 = pointn (length p) p in
let c = scale n fullcircle in
cut_after (shift p1 c) (cut_before (shift p0 c) p)
(* directed paths *)
type orientation =
| Up | Down | Left | Right
| Upn of Num.t | Downn of Num.t | Leftn of Num.t | Rightn of Num.t
let divise_dir l =
let rec fct left_down right_up listn =function
|[] -> left_down,right_up,listn
|((Leftn _|Rightn _|Downn _|Upn _) as x) ::res -> fct left_down right_up (x::listn) res
|((Left|Down) as x) ::res -> fct (x::left_down) right_up listn res
|((Right|Up) as x) ::res -> fct left_down (x::right_up) listn res
in
fct [] [] [] l
open Num
open Num.Infix
open Point
let dist_horizontal dirlist abs distance =
let left,right,listn = divise_dir dirlist in
let diff = (List.length right) - (List.length left) in
let distance = gmean distance zero in
let d = List.fold_left (fun a x -> match x with
|Leftn n -> (-/) a n
|Rightn n -> (+/) a n
|_ -> failwith "impossible") distance listn in
let dist,b = if diff = 0 then (bp 10.),false else (gmean ((/./) d (float diff)) zero),true in
let rec fct acc abs = function
|[] -> List.rev acc
|Left::res ->
let abs = (-/) abs dist in
fct (abs::acc) abs res
|Leftn n::res -> let abs = (-/) abs n in
fct (abs::acc) abs res
|Right::res ->
let abs = (+/) abs dist in
fct (abs::acc) abs res
|Rightn n::res -> let abs = (+/) abs n in
fct (abs::acc) abs res
|_ -> failwith "impossible"
in
fct [] abs dirlist
let dist_vertical dirlist ordo distance =
let down,up,listn = divise_dir dirlist in
let diff = (List.length up) - (List.length down) in
let d = List.fold_left (fun a x -> match x with
|Downn n -> (-/) a n
|Upn n -> (+/) a n
|_ -> failwith "impossible") distance listn in
let dist,b = if diff = 0 then (bp 10.),false else (gmean ((/./) d (float diff)) zero),true in
let rec fct acc ordo = function
|[] -> List.rev acc
|Down::res ->
let ordo = (-/) ordo dist in
fct (ordo::acc) ordo res
|Downn n::res -> let ordo = (-/) ordo n in
fct (ordo::acc) ordo res
|Up::res ->
let ordo = (+/) ordo dist in
fct (ordo::acc) ordo res
|Upn n::res -> let ordo = (+/) ordo n in
fct (ordo::acc) ordo res
|_ -> failwith "impossible"
in
fct [] ordo dirlist
let smart_path ?style dirlist p1 p2 =
let width = (-/) (xpart p2) (xpart p1) in
let height = (-/) (ypart p2) (ypart p1) in
let dirhorizontal, dirvertical = List.partition
(fun x -> match x with |(Left|Right|Leftn _|Rightn _) -> true |_->false) dirlist in
let lesdisth = dist_horizontal dirhorizontal (xpart p1) width in
let lesdistv = dist_vertical dirvertical (ypart p1) height in
let rec fct pc acc dirl dv dh =
match dirl,dv,dh with
|(Up|Upn _|Down|Downn _)::dres,
dv::dvres,
dhlist ->
let ps = pt (xpart pc, dv) in
fct ps (ps::acc) dres dvres dhlist
|(Left|Leftn _|Right|Rightn _)::dres,
dvlist,
dh::dhres ->
let ps = pt (dh, (ypart pc)) in
fct ps (ps::acc) dres dvlist dhres
|[],_, _ -> List.rev (p2::acc)
|_ -> assert false
in
let points = fct p1 [p1] dirlist lesdistv lesdisth
in
pathp ?style points
let draw ?brush ?color ?pen ?dashed t =
(* We don't use a default to avoid the output of
... withcolor (0.00red+0.00green+0.00blue) withpen ....
for each command in the output file *)
mkCommand (mkCDraw t (mkBrushOpt brush color pen dashed))
let fill ?color t =
mkCommand (mkCFill t color)
|
