(**************************************************************************)
(*                                                                        *)
(*  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)
