/[geocaml]/geocaml/src/geom.ml
ViewVC logotype

Diff of /geocaml/src/geom.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by adoniec, Wed Sep 10 15:35:59 2003 UTC revision 1.6 by gmariano, Wed Oct 29 10:52:53 2003 UTC
# Line 67  let add_point p name col fig = fig.point Line 67  let add_point p name col fig = fig.point
67  let rec point_depend_of abr name =  let rec point_depend_of abr name =
68    match abr with    match abr with
69        Point s -> s = name        Point s -> s = name
70      | Inter_line_line (s,(l1,l2)) -> (s = name) || (line_depend_of l1 name) || (line_depend_of l2 name)      | Inter_line_line (s,(l1,l2)) -> (s = name)
71      | Point_on_line (s,l) -> (s = name) || (line_depend_of l name)          || (line_depend_of l1 name)
72      | Point_on_circle (s,c) -> (s = name) || (circle_depend_of c name)          || (line_depend_of l2 name)
73      | Middle (s,(p1,p2)) -> (s = name) || (point_depend_of p1 name) || (point_depend_of p2 name)      | Point_on_line (s,l) ->    (s = name)
74      | Inter_circle_line (s1,s2,(c,l)) -> (s1 = name) || (s2 = name) || (circle_depend_of c name) || (line_depend_of l name)          || (line_depend_of l name)
75      | Inter_circle_circle (s1,s2,(c1,c2)) -> (s1 = name) || (s2 = name) || (circle_depend_of c1 name) || (circle_depend_of c2 name)      | Point_on_circle (s,c) ->  (s = name)
76            || (circle_depend_of c name)
77        | Middle (s,(p1,p2)) -> (s = name)
78            || (point_depend_of p1 name)
79            || (point_depend_of p2 name)
80        | Inter_circle_line (s1,s2,(c,l)) -> (s1 = name)
81            || (s2 = name)
82            || (circle_depend_of c name)
83            || (line_depend_of l name)
84        | Inter_circle_circle (s1,s2,(c1,c2)) -> (s1 = name)
85            || (s2 = name)
86            || (circle_depend_of c1 name)
87            || (circle_depend_of c2 name)
88      | Construct_point p -> point_depend_of p name      | Construct_point p -> point_depend_of p name
89    
90  and line_depend_of abr name =  and line_depend_of abr name =
91    match abr with    match abr with
92        Line (s,(p1,p2)) -> (s = name) || (point_depend_of p1 name) || (point_depend_of p2 name)        Line (s,(p1,p2)) ->       (s = name)
93      | Ruler l -> (line_depend_of l name)          || (point_depend_of p1 name)
94      | Segment (s,(p1,p2)) -> (s = name) || (point_depend_of p1 name) || (point_depend_of p2 name)          || (point_depend_of p2 name)
95      | Perpendicular (s,(l,p)) -> (s = name) || (line_depend_of l name) || (point_depend_of p name)      | Ruler l ->        (line_depend_of l name)
96      | Perpendicular_segment (s,(l,p1,(p2,p3))) -> (s = name) || (line_depend_of l name) || (point_depend_of p1 name) || (point_depend_of p2 name) || (point_depend_of p3 name)      | Segment (s,(p1,p2)) ->    (s = name)
97      | Perpendicular_bissector (s,l) -> (s = name) || (line_depend_of l name)          || (point_depend_of p1 name)
98      | Parallel (s,(l,p)) -> (s = name) || (line_depend_of l name) || (point_depend_of p name)          || (point_depend_of p2 name)
99      | Parallel_segment (s,(l,p1,(p2,p3))) -> (s = name) || (line_depend_of l name) || (point_depend_of p1 name) || (point_depend_of p2 name) || (point_depend_of p3 name)      | Perpendicular (s,(l,p)) ->        (s = name)
100      | Bissecting (s,(p1,p2,p3)) -> (s = name) || (point_depend_of p1 name) || (point_depend_of p2 name) || (point_depend_of p3 name)          || (line_depend_of l name)
101            || (point_depend_of p name)
102        | Perpendicular_segment (s,(l,p1,(p2,p3))) ->       (s = name)
103            || (line_depend_of l name)
104            || (point_depend_of p1 name)
105            || (point_depend_of p2 name)
106            || (point_depend_of p3 name)
107        | Perpendicular_bissector (s,l) -> (s = name)
108            || (line_depend_of l name)
109        | Parallel (s,(l,p)) -> (s = name)
110            || (line_depend_of l name)
111            || (point_depend_of p name)
112        | Parallel_segment (s,(l,p1,(p2,p3))) -> (s = name)
113            || (line_depend_of l name)
114            || (point_depend_of p1 name)
115            || (point_depend_of p2 name)
116            || (point_depend_of p3 name)
117        | Bissecting (s,(p1,p2,p3)) -> (s = name)
118            || (point_depend_of p1 name)
119            || (point_depend_of p2 name)
120            || (point_depend_of p3 name)
121    
122  and circle_depend_of abr name =  and circle_depend_of abr name =
123    match abr with    match abr with
124      | Circle (s,(p1,p2)) -> (s = name) || (point_depend_of p1 name) || (point_depend_of p2 name)      | Circle (s,(p1,p2)) ->
125            (s = name)
126            || (point_depend_of p1 name)
127            || (point_depend_of p2 name)
128      | Compass c -> circle_depend_of c name      | Compass c -> circle_depend_of c name
129    
130  let suppr_obj name fig f =  let suppr_obj name fig f =
131    begin    begin
132      fig.point_list := List.filter (fun (s,_,a) -> if point_depend_of a name then (f#remove_point s;false) else true) !(fig.point_list);      fig.point_list := List.filter
133      fig.line_list := List.filter (fun (s,_,a) -> if line_depend_of a name then (f#remove_line s;false) else true) !(fig.line_list);        (fun (s,_,a) ->
134      fig.circle_list := List.filter (fun (s,_,a) -> if circle_depend_of a name then (f#remove_circle s;false) else true) !(fig.circle_list)           if point_depend_of a name
135             then (f#remove_point s;false)
136             else true) !(fig.point_list);
137        fig.line_list := List.filter
138          (fun (s,_,a) ->
139             if line_depend_of a name
140             then (f#remove_line s;false)
141             else true) !(fig.line_list);
142        fig.circle_list := List.filter
143          (fun (s,_,a) ->
144             if circle_depend_of a name
145             then (f#remove_circle s;false)
146             else true) !(fig.circle_list)
147    end    end
148            
149  let add_line l name col fig = fig.line_list := (name,col,l)::!(fig.line_list)  let add_line l name col fig = fig.line_list := (name,col,l)::!(fig.line_list)
150    
151  let add_circle c name col fig = fig.circle_list := (name,col,c)::!(fig.circle_list)  let add_circle c name col fig = fig.circle_list := (name,col,c)::!(fig.circle_list)
152    
153  (*--------------------------------------------------------------------*)  
154  let point name = Point name  let point name = Point name
155    
156  let inter_line_line l1 l2 name = Inter_line_line (name,(l1,l2))  let inter_line_line l1 l2 name = Inter_line_line (name,(l1,l2))
# Line 174  let rec expand_line l = Line 221  let rec expand_line l =
221    | Line (s,(p1,p2)) -> (p1,p2)    | Line (s,(p1,p2)) -> (p1,p2)
222    | Ruler l1 -> expand_line l1    | Ruler l1 -> expand_line l1
223    | Segment (s,(p1,p2)) -> (p1,p2)    | Segment (s,(p1,p2)) -> (p1,p2)
224    | Perpendicular (s,(l1,p)) -> let (p1,p2) = expand_line l1 in    | Perpendicular (s,(l1,p)) ->
225                                  let c = Compass (if ((name_of_point p1)=(name_of_point p)) then circle p p2 (Generate.circle_name ())        let (p1,p2) = expand_line l1 in
226                                  else circle p p1 (Generate.circle_name ())) in        let c = Compass (if ((name_of_point p1)=(name_of_point p))
227                                  let (name1,name2) = (Generate.point_name (),Generate.point_name ()) in                         then circle p p2 (Generate.circle_name ())
228                                  let a = Construct_point (inter_circle_line c l1 name1 name2) in                         else circle p p1 (Generate.circle_name ())) in
229                                  let b = Construct_point (inter_circle_line c l1 name2 name1) in        let (name1,name2) = (Generate.point_name (),Generate.point_name ()) in
230                                  let c1 = Compass (circle a b (Generate.circle_name ())) in        let a = Construct_point (inter_circle_line c l1 name1 name2) in
231                                  let c2 = Compass (circle b a (Generate.circle_name ())) in        let b = Construct_point (inter_circle_line c l1 name2 name1) in
232                                  let (name3,name4) = (Generate.point_name (),Generate.point_name ()) in        let c1 = Compass (circle a b (Generate.circle_name ())) in
233                                  let e = inter_circle_circle c1 c2 name3 name4 in        let c2 = Compass (circle b a (Generate.circle_name ())) in
234                                  let f = inter_circle_circle c2 c1 name4 name3 in        let (name3,name4) = (Generate.point_name (),Generate.point_name ()) in
235                                  (e,f)        let e = inter_circle_circle c1 c2 name3 name4 in
236    | Perpendicular_segment (s,(l1,p,(_,_))) -> let (p1,p2) = expand_line l1 in        let f = inter_circle_circle c2 c1 name4 name3 in
237                                                let c = Compass (if ((name_of_point p1)=(name_of_point p)) then circle p p2 (Generate.circle_name ())          (e,f)
238                                                else circle p p1 (Generate.circle_name ())) in    | Perpendicular_segment (s,(l1,p,(_,_))) ->
239                                                let (name1,name2) = (Generate.point_name (),Generate.point_name ()) in        let (p1,p2) = expand_line l1 in
240                                                let a = Construct_point (inter_circle_line c l1 name1 name2) in        let c = Compass (if ((name_of_point p1)=(name_of_point p))
241                                                let b = Construct_point (inter_circle_line c l1 name2 name1) in                         then circle p p2 (Generate.circle_name ())
242                                                let c1 = Compass (circle a b (Generate.circle_name ())) in                         else circle p p1 (Generate.circle_name ())) in
243                                                let c2 = Compass (circle b a (Generate.circle_name ())) in        let (name1,name2) = (Generate.point_name (),Generate.point_name ()) in
244                                                let (name3,name4) = (Generate.point_name (),Generate.point_name ()) in        let a = Construct_point (inter_circle_line c l1 name1 name2) in
245                                                let e = inter_circle_circle c1 c2 name3 name4 in        let b = Construct_point (inter_circle_line c l1 name2 name1) in
246                                                let f = inter_circle_circle c2 c1 name4 name3 in        let c1 = Compass (circle a b (Generate.circle_name ())) in
247                                                (e,f)        let c2 = Compass (circle b a (Generate.circle_name ())) in
248    | Perpendicular_bissector (s,l1) -> let (p1,p2) = expand_line l1 in        let (name3,name4) = (Generate.point_name (),Generate.point_name ()) in
249                                        let c1 = Compass (circle p1 p2 (Generate.circle_name ())) in        let e = inter_circle_circle c1 c2 name3 name4 in
250                                        let c2 = Compass (circle p2 p1 (Generate.circle_name ())) in        let f = inter_circle_circle c2 c1 name4 name3 in
251                                        let (name1,name2) = (Generate.point_name (),Generate.point_name ()) in          (e,f)
252                                        let a = inter_circle_circle c1 c2 name1 name2 in    | Perpendicular_bissector (s,l1) ->
253                                        let b = inter_circle_circle c1 c2 name2 name1 in        let (p1,p2) = expand_line l1 in
254                                        (a,b)        let c1 = Compass (circle p1 p2 (Generate.circle_name ())) in
255    | Parallel (s,(l1,p)) -> let d = perpendicular l p (Generate.line_name ()) in        let c2 = Compass (circle p2 p1 (Generate.circle_name ())) in
256                                let d2 = perpendicular d p s in        let (name1,name2) = (Generate.point_name (),Generate.point_name ()) in
257                                expand_line d2        let a = inter_circle_circle c1 c2 name1 name2 in
258    | Parallel_segment (s,(l1,p,(_,_))) -> let d = perpendicular l p (Generate.line_name ()) in        let b = inter_circle_circle c1 c2 name2 name1 in
259                                           let d2 = perpendicular d p s in          (a,b)
260                                           expand_line d2    | Parallel (s,(l1,p)) ->
261          let d = perpendicular l p (Generate.line_name ()) in
262          let d2 = perpendicular d p s in
263            expand_line d2
264      | Parallel_segment (s,(l1,p,(_,_))) ->
265          let d = perpendicular l p (Generate.line_name ()) in
266          let d2 = perpendicular d p s in
267            expand_line d2
268    | Bissecting (s,(p1,p2,p3)) -> raise Error    | Bissecting (s,(p1,p2,p3)) -> raise Error
269          
270  (* parcours de l arbre *)  (* parcours de l arbre *)
271          
272  let rec draw_point p f col flag =  let rec draw_point p f col flag =
273    match p with    match p with
274    | Point s -> (try f#get_point s with      | Point s ->
275                  | Not_found -> Drawing.point (Generate.xy (100,100) (540,380)) s col flag f)          (try f#get_point s with
276    | Inter_line_line (s,(l1,l2)) -> (try f#get_point s with             | Not_found -> Drawing.point (Generate.xy (100,100) (540,380)) s col flag f)
277                                      | Not_found -> Drawing.inter_ll (draw_line l1 f Graphics.transp Drawing.DRAW) (draw_line l2 f Graphics.transp Drawing.DRAW) s col flag f)      | Inter_line_line (s,(l1,l2)) ->
278    | Inter_circle_line (s1,s2,(c,l)) -> (try f#get_point s1 with          (try f#get_point s with
279                                          | Not_found -> let (x,_) = Drawing.inter_lc (draw_line l f Graphics.transp Drawing.DRAW) (draw_circle c f Graphics.transp Drawing.DRAW) s1 s2 col flag f in x)             | Not_found -> Drawing.inter_ll (draw_line l1 f Graphics.transp Drawing.DRAW) (draw_line l2 f Graphics.transp Drawing.DRAW) s col flag f)
280    | Inter_circle_circle (s1,s2,(c1,c2)) -> (try f#get_point s1 with      | Inter_circle_line (s1,s2,(c,l)) ->
281                                              | Not_found -> let (x,_) = Drawing.inter_cc (draw_circle c1 f Graphics.transp Drawing.DRAW) (draw_circle c2 f Graphics.transp Drawing.DRAW) s1 s2 col flag f in x)          (try f#get_point s1 with
282    | Point_on_line (s,l) -> (try f#get_point s with             | Not_found ->
283                              | Not_found -> Drawing.point_on_line (draw_line l f Graphics.transp Drawing.DRAW) s col flag f)                 let (x,_) = Drawing.inter_lc (draw_line l f Graphics.transp Drawing.DRAW) (draw_circle c f Graphics.transp Drawing.DRAW) s1 s2 col flag f in x)
284    | Point_on_circle (s,c) -> (try f#get_point s with      | Inter_circle_circle (s1,s2,(c1,c2)) ->
285                                | Not_found -> Drawing.point_on_circle (draw_circle c f Graphics.transp Drawing.DRAW) s col flag f)          (try f#get_point s1 with
286    | Middle (s,(p1,p2)) -> (try f#get_point s with             | Not_found ->
287                             | Not_found -> Drawing.middle (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)                 let (x,_) = Drawing.inter_cc (draw_circle c1 f Graphics.transp Drawing.DRAW) (draw_circle c2 f Graphics.transp Drawing.DRAW) s1 s2 col flag f in x)
288      | Point_on_line (s,l) ->
289          (try f#get_point s with
290             | Not_found -> Drawing.point_on_line (draw_line l f Graphics.transp Drawing.DRAW) s col flag f)
291      | Point_on_circle (s,c) ->
292          (try f#get_point s with
293             | Not_found -> Drawing.point_on_circle (draw_circle c f Graphics.transp Drawing.DRAW) s col flag f)
294      | Middle (s,(p1,p2)) ->
295          (try f#get_point s with
296             | Not_found -> Drawing.middle (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)
297    | Construct_point pp -> draw_point pp f Graphics.transp Drawing.NO_DRAW    | Construct_point pp -> draw_point pp f Graphics.transp Drawing.NO_DRAW
298    | _ -> raise Error    | _ -> raise Error
299          
300  and draw_line l f col flag =  and draw_line l f col flag =
301    match l with    match l with
302    | Line (s,(p1,p2)) -> (try f#get_line s with      | Line (s,(p1,p2)) ->
303                           | Not_found -> Drawing.line (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)          (try f#get_line s with
304    | Ruler ll -> draw_line ll f Graphics.transp Drawing.NO_DRAW             | Not_found -> Drawing.line (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)
305    | Segment (s,(p1,p2)) -> (try f#get_line s with      | Ruler ll -> draw_line ll f Graphics.transp Drawing.NO_DRAW
306      | Segment (s,(p1,p2)) ->
307          (try f#get_line s with
308                              | Not_found -> Drawing.segment (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)                              | Not_found -> Drawing.segment (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)
309    | Perpendicular (s,(l,p)) -> (try f#get_line s with    | Perpendicular (s,(l,p)) ->
310                              | Not_found -> Drawing.perpendicular (draw_line l f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) s col flag f)        (try f#get_line s with
311    | Perpendicular_segment (s,(l,p,(p1,p2))) -> (try f#get_line s with           | Not_found -> Drawing.perpendicular (draw_line l f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) s col flag f)
312                              | Not_found -> Drawing.perpendicular_seg (draw_line l f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)    | Perpendicular_segment (s,(l,p,(p1,p2))) ->
313    | Parallel (s,(l,p)) -> (try f#get_line s with        (try f#get_line s with
314                         | Not_found -> Drawing.parallel (draw_line l f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) s col flag f)           | Not_found -> Drawing.perpendicular_seg (draw_line l f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)
315    | Parallel_segment (s,(l,p,(p1,p2))) -> (try f#get_line s with    | Parallel (s,(l,p)) ->
316                         | Not_found -> Drawing.parallel_seg (draw_line l f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)        (try f#get_line s with
317    | Bissecting (s,(p1,p2,p3)) -> (try f#get_line s with           | Not_found -> Drawing.parallel (draw_line l f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) s col flag f)
318                                    | Not_found -> Drawing.angle_bissector (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) (draw_point p3 f Graphics.transp Drawing.DRAW) s col flag f)    | Parallel_segment (s,(l,p,(p1,p2))) ->
319    | Perpendicular_bissector (s,l) -> (try f#get_line s with        (try f#get_line s with
320                                         | Not_found -> Drawing.perpendicular_bissector (draw_line l f Graphics.transp Drawing.DRAW) s col flag f)           | Not_found -> Drawing.parallel_seg (draw_line l f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) s col flag f)
321      | Bissecting (s,(p1,p2,p3)) ->
322          (try f#get_line s with
323             | Not_found -> Drawing.angle_bissector (draw_point p1 f Graphics.transp Drawing.DRAW) (draw_point p2 f Graphics.transp Drawing.DRAW) (draw_point p3 f Graphics.transp Drawing.DRAW) s col flag f)
324      | Perpendicular_bissector (s,l) ->
325          (try f#get_line s with
326             | Not_found -> Drawing.perpendicular_bissector (draw_line l f Graphics.transp Drawing.DRAW) s col flag f)
327          
328    | _ -> raise Error    | _ -> raise Error
329          
330  and draw_circle c f col flag =  and draw_circle c f col flag =
331    match c with    match c with
332    | Circle (s,(o,p)) -> (try f#get_circle s with      | Circle (s,(o,p)) ->
333                           | Not_found -> Drawing.circle (draw_point o f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) s col flag f)          (try f#get_circle s with
334    | Compass cc -> draw_circle cc f Graphics.transp Drawing.NO_DRAW             | Not_found -> Drawing.circle (draw_point o f Graphics.transp Drawing.DRAW) (draw_point p f Graphics.transp Drawing.DRAW) s col flag f)
335    | _ -> raise Error      | Compass cc -> draw_circle cc f Graphics.transp Drawing.NO_DRAW
336        | _ -> raise Error
337            
338  let draw_figure abstract_figure drawn_figure flag =  let draw_figure abstract_figure drawn_figure flag =
339    List.iter (fun (_,col,p) -> draw_point p drawn_figure col flag;()) (List.rev !(abstract_figure.point_list));    List.iter (fun (_,col,p) -> draw_point p drawn_figure col flag;()) (List.rev !(abstract_figure.point_list));
340    List.iter (fun (_,col,l) -> draw_line l drawn_figure col flag;()) (List.rev !(abstract_figure.line_list));    List.iter (fun (_,col,l) -> draw_line l drawn_figure col flag;()) (List.rev !(abstract_figure.line_list));
# Line 272  let draw_figure abstract_figure drawn_fi Line 344  let draw_figure abstract_figure drawn_fi
344    
345  let rec write_point p level =  let rec write_point p level =
346    match p with    match p with
347    | Point s -> (if Xml.is_a_declared_point s then (if level = 0 then Xml.do_nothing else Xml.point s level)      | Point s ->
348                  else Xml.point_declaration s (Generate.xy (100,100) (540,380)) level)          (if Xml.is_a_declared_point s
349    | Inter_line_line (s,(l1,l2)) -> (if Xml.is_a_declared_point s then (if level = 0 then Xml.do_nothing else Xml.point s level)           then (if level = 0 then Xml.do_nothing else Xml.point s level)
350                                      else Xml.inter_line_line s (write_line l1 (level+1)) (write_line l2 (level+1)) level)           else Xml.point_declaration s (Generate.xy (100,100) (540,380)) level)
351    | Inter_circle_line (s1,s2,(c,l)) -> (if Xml.is_a_declared_point s1 then (if level = 0 then Xml.do_nothing else Xml.point s1 level)      | Inter_line_line (s,(l1,l2)) ->
352                                          else Xml.inter_circle_line s1 (write_circle c (level+1)) (write_line l (level+1)) level)          (if Xml.is_a_declared_point s
353    | Inter_circle_circle (s1,s2,(c1,c2)) -> (if Xml.is_a_declared_point s1 then (if level = 0 then Xml.do_nothing else Xml.point s1 level)           then (if level = 0 then Xml.do_nothing else Xml.point s level)
354                                              else Xml.inter_circle_circle s1 (write_circle c1 (level+1)) (write_circle c2 (level+1)) level)           else Xml.inter_line_line s
355    | Point_on_line (s,l) -> (if Xml.is_a_declared_point s then (if level = 0 then Xml.do_nothing else Xml.point s level)             (write_line l1 (level+1))
356                              else Xml.point_on_line s (write_line l (level+1)) level)             (write_line l2 (level+1)) level)
357    | Point_on_circle (s,c) -> (if Xml.is_a_declared_point s then (if level = 0 then Xml.do_nothing else Xml.point s level)      | Inter_circle_line (s1,s2,(c,l)) ->
358                                else Xml.point_on_circle s (write_circle c (level+1)) level)          (if Xml.is_a_declared_point s1
359    | Middle (s,(p1,p2)) -> (if Xml.is_a_declared_point s then (if level = 0 then Xml.do_nothing else Xml.point s level)           then (if level = 0
360                             else Xml.middle s (write_point p1 (level+1)) (write_point p2 (level+1)) level)                 then Xml.do_nothing
361    | Construct_point p1 -> write_point p1 level                 else Xml.point s1 level)
362             else Xml.inter_circle_line s1
363               (write_circle c (level+1))
364               (write_line l (level+1)) level)
365        | Inter_circle_circle (s1,s2,(c1,c2)) ->
366            (if Xml.is_a_declared_point s1
367             then (if level = 0 then Xml.do_nothing else Xml.point s1 level)
368             else Xml.inter_circle_circle s1
369               (write_circle c1 (level+1))
370               (write_circle c2 (level+1)) level)
371        | Point_on_line (s,l) ->
372            (if Xml.is_a_declared_point s
373             then (if level = 0 then Xml.do_nothing else Xml.point s level)
374             else Xml.point_on_line s (write_line l (level+1)) level)
375        | Point_on_circle (s,c) ->
376            (if Xml.is_a_declared_point s
377             then (if level = 0 then Xml.do_nothing else Xml.point s level)
378             else Xml.point_on_circle s (write_circle c (level+1)) level)
379        | Middle (s,(p1,p2)) ->
380            (if Xml.is_a_declared_point s
381             then (if level = 0 then Xml.do_nothing else Xml.point s level)
382             else Xml.middle s (write_point p1 (level+1)) (write_point p2 (level+1)) level)
383        | Construct_point p1 -> write_point p1 level
384            
385  and write_line l level=  and write_line l level=
386    match l with    match l with
387    | Line (s,(p1,p2)) -> (if Xml.is_a_declared_line s then (if level = 0 then Xml.do_nothing else Xml.line s level)      | Line (s,(p1,p2)) ->
388                             else Xml.line_declaration s (write_point p1 (level+1)) (write_point p2 (level+1)) level)          (if Xml.is_a_declared_line s
389    | Segment (s,(p1,p2)) -> (if Xml.is_a_declared_line s then (if level = 0 then Xml.do_nothing else Xml.line s level)           then (if level = 0
390                             else Xml.segment s (write_point p1 (level+1)) (write_point p2 (level+1)) level)                 then Xml.do_nothing
391    | Perpendicular (s,(l,p)) -> (if Xml.is_a_declared_line s then (if level = 0 then Xml.do_nothing else Xml.line s level)                 else Xml.line s level)
392                                  else Xml.perpendicular s (write_line l (level+1)) (write_point p (level+1)) level)           else Xml.line_declaration s (write_point p1 (level+1)) (write_point p2 (level+1)) level)
393    | Perpendicular_bissector (s,l) -> (if Xml.is_a_declared_line s then (if level = 0 then Xml.do_nothing else Xml.line s level)      | Segment (s,(p1,p2)) ->
394                                        else Xml.perpendicular_bissector s (write_line l (level+1)) level)          (if Xml.is_a_declared_line s
395    | Parallel (s,(l,p)) -> (if Xml.is_a_declared_line s then (if level = 0 then Xml.do_nothing else Xml.line s level)           then (if level = 0
396                            else Xml.parallel s (write_line l (level+1)) (write_point p (level+1)) level)                 then Xml.do_nothing
397    | Bissecting (s,(p1,p2,p3)) -> (if Xml.is_a_declared_line s then (if level = 0 then Xml.do_nothing else Xml.line s level)                 else Xml.line s level)
398                                    else Xml.bissecting s (write_point p1 (level+1)) (write_point p2 (level+1)) (write_point p3 (level+1)) level)            
399             else Xml.segment s (write_point p1 (level+1)) (write_point p2 (level+1)) level)
400        | Perpendicular (s,(l,p)) ->
401            (if Xml.is_a_declared_line s
402             then (if level = 0
403                   then Xml.do_nothing
404                   else Xml.line s level)
405             else Xml.perpendicular s (write_line l (level+1)) (write_point p (level+1)) level)
406        | Perpendicular_bissector (s,l) ->
407            (if Xml.is_a_declared_line s then
408               (if level = 0 then Xml.do_nothing else Xml.line s level)
409             else Xml.perpendicular_bissector s (write_line l (level+1)) level)
410        | Parallel (s,(l,p)) ->
411            (if Xml.is_a_declared_line s
412             then (if level = 0
413                   then Xml.do_nothing
414                   else Xml.line s level)
415             else Xml.parallel s (write_line l (level+1)) (write_point p (level+1)) level)
416      | Bissecting (s,(p1,p2,p3)) ->
417          (if Xml.is_a_declared_line s
418           then (if level = 0
419                 then Xml.do_nothing
420                 else Xml.line s level)
421           else Xml.bissecting s
422             (write_point p1 (level+1))
423             (write_point p2 (level+1))
424             (write_point p3 (level+1)) level)
425    | Ruler l1 -> write_line l1 level    | Ruler l1 -> write_line l1 level
426          
427  and write_circle c level=  and write_circle c level=
428    match c with    match c with
429    | Circle (s,(o,p)) -> (if Xml.is_a_declared_circle s then (if level = 0 then Xml.do_nothing else Xml.circle s level)      | Circle (s,(o,p)) ->
430                           else Xml.circle_declaration s (write_point o (level+1)) (write_point p (level+1)) level)          (if Xml.is_a_declared_circle s
431    | Compass c1 -> write_circle c1 level           then (if level = 0 then Xml.do_nothing else Xml.circle s level)
432             else Xml.circle_declaration s
433               (write_point o (level+1))
434               (write_point p (level+1)) level)
435        | Compass c1 -> write_circle c1 level
436            
437  let write_figure abstract_figure channel =  let write_figure abstract_figure channel =
438    List.iter (fun (_,_,p) -> (write_point p 0) channel;()) (List.rev !(abstract_figure.point_list));    List.iter
439    List.iter (fun (_,_,l) -> (write_line l 0) channel;()) (List.rev !(abstract_figure.line_list));      (fun (_,_,p) ->
440    List.iter (fun (_,_,c) -> (write_circle c 0) channel;()) (List.rev !(abstract_figure.circle_list))         (write_point p 0) channel;()) (List.rev !(abstract_figure.point_list));
441      List.iter
442        (fun (_,_,l) ->
443           (write_line l 0) channel;()) (List.rev !(abstract_figure.line_list));
444      List.iter
445        (fun (_,_,c) ->
446           (write_circle c 0) channel;()) (List.rev !(abstract_figure.circle_list))
447    
448  (* XML expansed writer*)  (* XML expansed writer*)
449  let rec write_point2 p col level =  let rec write_point2 p col level =
450    match p with    match p with
451    | Point s -> ( let (is_here,colour) = Xmlexpansed.is_a_declared_point s in      | Point s ->
452                  if is_here then (if level = 0 then Xmlexpansed.do_nothing else Xmlexpansed.point s colour level)          (let (is_here,colour) = Xmlexpansed.is_a_declared_point s in
453                  else Xmlexpansed.point_declaration s (Generate.xy (0,0) (10,10)) col level)             if is_here
454    | Inter_line_line (s,(l1,l2)) -> ( let (is_here,colour) = Xmlexpansed.is_a_declared_point s in             then (if level = 0
455                                       if is_here then (if level = 0 then Xmlexpansed.do_nothing else Xmlexpansed.point s colour level)                   then Xmlexpansed.do_nothing
456                                      else Xmlexpansed.inter_line_line s (write_line2 l1 "black" (level+1)) (write_line2 l2 "black" (level+1)) col level)                   else Xmlexpansed.point s colour level)
457    | Inter_circle_line (s1,s2,(c,l)) -> (let (is_here,colour) = Xmlexpansed.is_a_declared_point s1 in             else Xmlexpansed.point_declaration s (Generate.xy (0,0) (10,10)) col level)
458                                          if is_here then (if level = 0 then Xmlexpansed.do_nothing else Xmlexpansed.point s1 colour level)      | Inter_line_line (s,(l1,l2)) ->
459                                          else Xmlexpansed.inter_circle_line s1 s2 (write_circle2 c "black" (level+1)) (write_line2 l "black" (level+1)) col level)          (let (is_here,colour) = Xmlexpansed.is_a_declared_point s in
460    | Inter_circle_circle (s1,s2,(c1,c2)) -> (let (is_here,colour) = Xmlexpansed.is_a_declared_point s1 in             if is_here then (if level = 0
461                                              if is_here then (if level = 0 then Xmlexpansed.do_nothing else Xmlexpansed.point s1 colour level)                              then Xmlexpansed.do_nothing
462                                              else Xmlexpansed.inter_circle_circle s1 s2 (write_circle2 c1 "black" (level+1)) (write_circle2 c2 "black" (level+1)) col level)                              else Xmlexpansed.point s colour level)
463    | Point_on_line (s,l) -> (let (is_here,colour) = Xmlexpansed.is_a_declared_point s in             else Xmlexpansed.inter_line_line s
464                              if is_here then (if level = 0 then Xmlexpansed.do_nothing else Xmlexpansed.point s colour level)               (write_line2 l1 "black" (level+1))
465                              else Xmlexpansed.point_on_line s (write_line2 l "black" (level+1)) col level)               (write_line2 l2 "black" (level+1)) col level)
466    | Point_on_circle (s,c) -> (let (is_here,colour) = Xmlexpansed.is_a_declared_point s in      | Inter_circle_line (s1,s2,(c,l)) ->
467                                if is_here then (if level = 0 then Xmlexpansed.do_nothing else Xmlexpansed.point s colour level)          (let (is_here,colour) = Xmlexpansed.is_a_declared_point s1 in
468                                else Xmlexpansed.point_on_circle s (write_circle2 c "black" (level+1)) col level)             if is_here then (if level = 0
469    | Middle (s,(p1,p2)) -> (let (is_here,colour) = Xmlexpansed.is_a_declared_point s in                              then Xmlexpansed.do_nothing
470                             if is_here then (if level = 0 then Xmlexpansed.do_nothing else Xmlexpansed.point s colour level)                              else Xmlexpansed.point s1 colour level)
471                             else Xmlexpansed.middle s (write_point2 p1 "red" (level+1)) (write_point2 p2 "red" (level+1)) col level)             else Xmlexpansed.inter_circle_line s1 s2
472                 (write_circle2 c "black" (level+1))
473    | Construct_point p1 -> write_point2 p1 "white" level               (write_line2 l "black" (level+1)) col level)
474        | Inter_circle_circle (s1,s2,(c1,c2)) ->
475            (let (is_here,colour) = Xmlexpansed.is_a_declared_point s1 in
476               if is_here then (if level = 0
477                                then Xmlexpansed.do_nothing
478                                else Xmlexpansed.point s1 colour level)
479               else Xmlexpansed.inter_circle_circle s1 s2
480                 (write_circle2 c1 "black" (level+1))
481                 (write_circle2 c2 "black" (level+1)) col level)
482        | Point_on_line (s,l) ->
483            (let (is_here,colour) = Xmlexpansed.is_a_declared_point s in
484               if is_here then (if level = 0
485                                then Xmlexpansed.do_nothing
486                                else Xmlexpansed.point s colour level)
487               else Xmlexpansed.point_on_line s (write_line2 l "black" (level+1)) col level)
488        | Point_on_circle (s,c) ->
489            (let (is_here,colour) = Xmlexpansed.is_a_declared_point s in
490               if is_here then (if level = 0
491                                then Xmlexpansed.do_nothing
492                                else Xmlexpansed.point s colour level)
493               else Xmlexpansed.point_on_circle s (write_circle2 c "black" (level+1)) col level)
494        | Middle (s,(p1,p2)) ->
495            (let (is_here,colour) = Xmlexpansed.is_a_declared_point s in
496               if is_here then (if level = 0
497                                then Xmlexpansed.do_nothing
498                                else Xmlexpansed.point s colour level)
499               else Xmlexpansed.middle s (write_point2 p1 "red" (level+1)) (write_point2 p2 "red" (level+1)) col level)
500            
501        | Construct_point p1 -> write_point2 p1 "white" level
502            
503  and write_line2 l col level=  and write_line2 l col level=
504    match l with    match l with
505    | Line (s,(p1,p2)) -> (let (is_here,colour) = Xmlexpansed.is_a_declared_line s in      | Line (s,(p1,p2)) ->
506                           if is_here then          (let (is_here,colour) = Xmlexpansed.is_a_declared_line s in
507                             Xmlexpansed.line_declaration s (Xmlexpansed.do_nothing) (Xmlexpansed.do_nothing) (name_of_point p1) (name_of_point p2) colour level             if is_here
508                           else             then
509                             Xmlexpansed.line_declaration s (write_point2 p1 col (level+1)) (write_point2 p2 col (level+1)) (name_of_point p1) (name_of_point p2) col level)               Xmlexpansed.line_declaration s
510    | Segment (s,(p1,p2)) -> (let (is_here,colour) = Xmlexpansed.is_a_declared_line s in                 (Xmlexpansed.do_nothing)
511                           if is_here then                 (Xmlexpansed.do_nothing)
512                             Xmlexpansed.segment s (Xmlexpansed.do_nothing) (Xmlexpansed.do_nothing) (name_of_point p1) (name_of_point p2) colour level                 (name_of_point p1)
513                           else                 (name_of_point p2) colour level
514                             Xmlexpansed.segment s (write_point2 p1 col (level+1)) (write_point2 p2 col (level+1)) (name_of_point p1) (name_of_point p2) col level)             else
515    | Perpendicular (s,_) -> write_line2 (Line (s,expand_line l)) col level               Xmlexpansed.line_declaration s
516    | Perpendicular_segment (s,_) -> write_line2 (Segment (s,expand_line l)) col level                 (write_point2 p1 col (level+1))
517    | Perpendicular_bissector (s,_) -> write_line2 (Line (s,expand_line l)) col level                 (write_point2 p2 col (level+1))
518    | Parallel (s,_) -> write_line2 (Line (s,expand_line l)) col level                 (name_of_point p1)
519    | Parallel_segment (s,_) -> write_line2 (Segment (s,expand_line l)) col level                 (name_of_point p2) col level)
520    | Bissecting (s,(p1,p2,p3)) -> raise Error      | Segment (s,(p1,p2)) ->
521    | Ruler l1 -> write_line2 l1 "white" level          (let (is_here,colour) = Xmlexpansed.is_a_declared_line s in
522               if is_here
523               then
524                 Xmlexpansed.segment s
525                   (Xmlexpansed.do_nothing)
526                   (Xmlexpansed.do_nothing)
527                   (name_of_point p1)
528                   (name_of_point p2) colour level
529               else
530                 Xmlexpansed.segment s
531                   (write_point2 p1 col (level+1))
532                   (write_point2 p2 col (level+1))
533                   (name_of_point p1)
534                   (name_of_point p2) col level)
535        | Perpendicular (s,_) ->
536            write_line2 (Line (s,expand_line l)) col level
537        | Perpendicular_segment (s,_) ->
538            write_line2 (Segment (s,expand_line l)) col level
539        | Perpendicular_bissector (s,_) ->
540            write_line2 (Line (s,expand_line l)) col level
541        | Parallel (s,_) ->
542            write_line2 (Line (s,expand_line l)) col level
543        | Parallel_segment (s,_) ->
544            write_line2 (Segment (s,expand_line l)) col level
545        | Bissecting (s,(p1,p2,p3)) ->
546            raise Error
547        | Ruler l1 ->
548            write_line2 l1 "white" level
549            
550  and write_circle2 c col level=  and write_circle2 c col level=
551    match c with    match c with
552    | Circle (s,(o,p)) -> (let (is_here,colour) = Xmlexpansed.is_a_declared_circle s in      | Circle (s,(o,p)) ->
553                           if is_here then          (let (is_here,colour) = Xmlexpansed.is_a_declared_circle s in
554                             Xmlexpansed.circle_declaration s (Xmlexpansed.do_nothing) (Xmlexpansed.do_nothing) (name_of_point o) (name_of_point p) colour level             if is_here
555                           else             then
556                             Xmlexpansed.circle_declaration s (write_point2 o col (level+1)) (write_point2 p col (level+1)) (name_of_point o) (name_of_point p) col level)               Xmlexpansed.circle_declaration s
557    | Compass c1 -> write_circle2 c1 "white" level                 (Xmlexpansed.do_nothing)
558                   (Xmlexpansed.do_nothing)
559                   (name_of_point o)
560                   (name_of_point p) colour level
561               else
562                 Xmlexpansed.circle_declaration s
563                   (write_point2 o col (level+1))
564                   (write_point2 p col (level+1))
565                   (name_of_point o)
566                   (name_of_point p) col level)
567        | Compass c1 -> write_circle2 c1 "white" level
568            
569  let write_figure2 abstract_figure channel =  let write_figure2 abstract_figure channel =
570    List.iter (fun (_,_,p) -> (write_point2 p "red" 0) channel;()) (List.rev !(abstract_figure.point_list));    List.iter
571    List.iter (fun (_,_,l) -> (write_line2 l "black" 0) channel;()) (List.rev !(abstract_figure.line_list));      (fun (_,_,p) ->
572    List.iter (fun (_,_,c) -> (write_circle2 c "black" 0) channel;()) (List.rev !(abstract_figure.circle_list))         (write_point2 p "red" 0) channel;()) (List.rev !(abstract_figure.point_list));
573      List.iter
574        (fun (_,_,l) ->
575           (write_line2 l "black" 0) channel;()) (List.rev !(abstract_figure.line_list));
576      List.iter
577        (fun (_,_,c) ->
578           (write_circle2 c "black" 0) channel;()) (List.rev !(abstract_figure.circle_list))
579  ;;  ;;
580    
581    

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26