summaryrefslogtreecommitdiff
path: root/support/syngen/src/picture.ml
blob: 87d7bbbd71b57326ba5a348ce3a163cc0c73f82e (plain)
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
type picture = Picture of float * float * float * float * pic_object list

and point = float * float

and pic_object = Line       of point * int * int * float * option list 
               | Circle     of point * float * option list
               | Oval       of point * float * float * option list
               | Text       of point * string * option list
               | Curve      of point * point * point * option list
               | SubPicture of point * picture * option list
               | Framebox   of point * float * float * option list

and option = Arrowhead 
           | Anchor of anchor * anchor
           | Filled
           | Dashed of float
           | Framed
           | Points of int

and anchor =  N | L | R | T | B

let string_of_anchor = function
  N -> "n" | L -> "l" | R -> "r" | T -> "t" | B -> "b"

let rec extract_anchor = function
    [] -> ""
  | Anchor (a1, a2) :: s -> "[" ^ (string_of_anchor a1) ^ 
                            (string_of_anchor a2) ^ "]"
  | _ :: s -> extract_anchor s

let rec extract_points = function
    [] -> ""
  | Points i :: s -> "[" ^ (string_of_int i) ^ "]"
  | _ :: s -> extract_points s

let rec extract_dashed = function
    [] -> ""
  | Dashed i :: s -> (string_of_float i) 
  | _ :: s -> extract_dashed s

let string_of_point (x, y) = 
  "(" ^ (string_of_float x) ^ "," ^ (string_of_float y) ^ ")"

let rec output_pic_objects channel = function
    [] -> ()
  | Line (p, xsl, ysl, length, ol) :: s -> (
      output_string channel (
        "\\put" ^ (string_of_point p) ^
        (if List.mem Arrowhead ol then "{\\vector(" else "{\\line(") ^ 
        (string_of_int xsl) ^ "," ^ (string_of_int ysl) ^ "){" ^
        (string_of_float length) ^ "}}%\n"
      );
      output_pic_objects channel s
    )
  | Circle (p, d, ol) :: s -> ( 
      let framed = List.mem Framed ol in
      output_string channel (
        "\\put" ^ (string_of_point p) ^
        (if framed then "{\\frame{" else "{") ^
        (if List.mem Filled ol then "\\circle*{" else "\\circle{") ^
        (string_of_float d) ^ 
        (if framed then "}}}%\n" else "}}%\n")
      );
      output_pic_objects channel s
    )
  | Oval (p, l, h, ol) :: s -> (
      let framed = List.mem Framed ol in
      output_string channel (
        "\\put" ^ (string_of_point p) ^
        (if framed then "{\\frame{" else "{") ^
        "\\oval" ^ (string_of_point (l, h)) ^ (extract_anchor ol) ^
        (if framed then "}}%\n" else "}%\n")
      );
      output_pic_objects channel s
    )
  | Text (p, t, ol) :: s -> (
      let framed = List.mem Framed ol in
      output_string channel (
        "\\put" ^ (string_of_point p) ^ 
        (if framed then "{\\frame{" else "{") ^
        "\\makebox(0,0)" ^ (extract_anchor ol) ^ "{" ^ t ^ 
        (if framed then "}}}%\n" else "}}%\n")
      );
      output_pic_objects channel s
    )
  | Curve (p1, p2, p3, ol) :: s -> (
      output_string channel (
        "\\qbezier" ^ (extract_points ol) ^ (string_of_point p1) ^ 
        (string_of_point p2) ^ (string_of_point p3) ^ "%\n" 
      );
      output_pic_objects channel s
    )
  | SubPicture (p, pic, ol) :: s -> (
      let framed = List.mem Framed ol in
      output_string channel (
        "\\put" ^ (string_of_point p) ^ 
        (if framed then "{\\frame{" else "{") 
      );
      output channel pic;
      output_string channel (if framed then "}}%\n" else "}%\n");
      output_pic_objects channel s
    )
  | Framebox (p, l, h, ol) :: s -> (
      let framed = List.mem Framed ol in
      output_string channel (
        "\\put" ^ (string_of_point p) ^ "{" ^
        ( let dc = extract_dashed ol 
          in if dc = "" then "\\framebox" 
             else "\\dashbox{" ^ dc ^ "}" ) ^
        (string_of_point (l, h)) ^ (extract_anchor ol) ^ "{%\n"
      );
      output_string channel "}}%\n";
      output_pic_objects channel s
    )

and output channel (Picture (xs, ys, xo, yo, l)) = (
  output_string channel (
    "\\begin{picture}" ^ (string_of_point (xs, ys)) ^ 
    (string_of_point (xo, yo)) ^ "%\n"
  );
  output_pic_objects channel l;
  output_string channel "\\end{picture}%\n"
)