diff options
Diffstat (limited to 'script.it/shapes')
| -rwxr-xr-x | script.it/shapes/bezier.ml | 228 | ||||
| -rwxr-xr-x | script.it/shapes/bezier.mli | 40 | ||||
| -rwxr-xr-x | script.it/shapes/bspline.ml | 149 | ||||
| -rwxr-xr-x | script.it/shapes/bspline.mli | 24 | ||||
| -rwxr-xr-x | script.it/shapes/dd_splines.pdf | bin | 0 -> 184248 bytes | |||
| -rwxr-xr-x | script.it/shapes/dune | 7 | ||||
| -rwxr-xr-x | script.it/shapes/matrix/EltsI.ml | 28 | ||||
| -rwxr-xr-x | script.it/shapes/matrix/Helpers.ml | 16 | ||||
| -rwxr-xr-x | script.it/shapes/matrix/Matrix.ml | 529 | ||||
| -rwxr-xr-x | script.it/shapes/matrix/MatrixI.ml | 105 | ||||
| -rwxr-xr-x | script.it/shapes/matrix/Order.ml | 2 | ||||
| -rwxr-xr-x | script.it/shapes/matrix/dune | 3 | ||||
| -rwxr-xr-x | script.it/shapes/tools/dune | 6 | ||||
| -rwxr-xr-x | script.it/shapes/tools/utils.ml | 63 | ||||
| -rwxr-xr-x | script.it/shapes/tools/utils.mli | 21 | 
15 files changed, 1221 insertions, 0 deletions
| diff --git a/script.it/shapes/bezier.ml b/script.it/shapes/bezier.ml new file mode 100755 index 0000000..f5f288c --- /dev/null +++ b/script.it/shapes/bezier.ml @@ -0,0 +1,228 @@ +(** + +   Bezier curve +*) + +module Utils = Tools.Utils + +type quadratic = +  { p0:Gg.v2     (* The starting point *) +  ; p1:Gg.v2     (* The end point *) +  ; ctrl:Gg.v2 } (* The control point *) + + +type t = +  { p0:Gg.v2      (* The starting point *) +  ; p1:Gg.v2      (* The end point *) +  ; ctrl0:Gg.v2   (* The control point *) +  ; ctrl1:Gg.v2 } (* The control point *) + + +(** +   Build a control point for a quadratic curve for passing throuht 3 points. +   taken from https://xuhehuan.com/2608.html + + +   also look to https://pomax.github.io/bezierinfo/#pointcurves +*) +let three_points_quadratic +  : Gg.v2 -> Gg.v2 -> Gg.v2 -> quadratic +  = fun p0 c1 p1 -> + +    let open Gg.V2 in + +    let vect_1 = p0 - c1 +    and vect_2 = p1 - c1 in +    let norm1 = norm vect_1 +    and norm2 = norm vect_2 in +    let v = (Float.sqrt (norm1 *. norm2)) /. 2. in + +    let ctrl = c1 - v * (( vect_1 / norm1) + (vect_2 / norm2)) in +    {p0; p1; ctrl} + +(** + +   Convert a cubic bezier curve into a quadratic one + +*) +let quadratic_to_cubic +  : quadratic -> t +  = fun {p0; p1; ctrl} -> + +    let coef = 2. /. 3. in + +    let open Gg.V2 in +    { p0 +    ; p1 +    ; ctrl0 = mix p0 ctrl coef +    ; ctrl1 = mix p1 ctrl coef } + + + +let abc_ratio +  : int -> float -> float +  = fun n t -> +    let n' = Float.of_int n in +    let bottom = (Float.pow t n') +. (Float.pow  (1. -. t) n') in +    let top = bottom -. 1. in +    Float.abs (top /. bottom) + +let half_cubic_ratio = abc_ratio 3 0.5 + +exception Not_found + +(** + +   https://pomax.github.io/bezierinfo/#pointcurves + +*) +let three_points_cubic +  : float -> Gg.v2 -> Gg.v2 -> Gg.v2 -> t +  = fun f p0 p1 p2 -> + +    let open Gg.V2 in + +    let c = half ( p0 + p2) in +    let a = p1 + ((p1 - c) / half_cubic_ratio) in + +    let vect1_0 = p1 - p0 in +    let vect2_0 = p2 - p0 in + +    let d1 = norm vect1_0 +    and d2 = norm (p2 - p1) in +    let t = d1 /. (d1 +. d2) in + +    let angle_1_0 = angle vect1_0 +    and angle_2_0 = angle vect2_0 in + +    (* get our e1-e2 distances *) +    let angle = mod_float +        (Gg.Float.two_pi +         +. angle_2_0 +         -. angle_1_0) +        Gg.Float.two_pi in + +    let distance = (norm vect2_0) *. f in + +    let bc = +      if angle < 0. || angle > Gg.Float.pi then +        Float.(neg distance) +      else +        distance in +    let de1  = t *. bc +    and de2 = (1. -. t) *. bc in + +    (* get the circle-aligned slope as normalized dx/dy *) +    let center = Utils.center p0 p1 p2 in +    match center with +    | None -> raise Not_found +    | Some center -> +      let t' = p1 - center in +      let tangent0 = v +          ((x p1) -. (y t')) +          ((y p1) +. (x t')) +      and tangent1 = v +          ((x p1) +. (y t')) +          ((y p1) -. (x t')) in + +      let d = unit (tangent1 - tangent0) in + +      (* then set up an e1 and e2 parallel to the baseline *) +      let e1 = p1 + de1 * d +      and e2 = p1 - de2 * d in + +      (* then use those e1/e2 to derive the new hull coordinates *) +      let v1 = a + (e1 - a) / (1. -. t) +      and v2 = a + (e2 - a) / t in + +      let ctrl0 = p0 + (v1 - p0) / t +      and ctrl1 = p2 + (v2 -p2) / (1. -. t) in + +      {p0; p1 = p2; ctrl0; ctrl1} + +(** Split a bezier curve in two at a given position *) +let slice +  : float -> t -> t * t +  = fun t {p0; p1; ctrl0; ctrl1} -> + +    let mix p1 p2 = Gg.V2.mix p1 p2 t in + +    let p12 = mix p0 ctrl0 +    and p23 = mix ctrl0 ctrl1 +    and p34 = mix ctrl1 p1 in + +    let p123 = mix p12 p23 +    and p234 = mix p23 p34 in + +    let p1234 = mix p123 p234 in + +    ( { p0 +      ; ctrl0 = p12 +      ; ctrl1 = p123 +      ; p1 = p1234 } +    , { p0 = p1234 +      ; ctrl0 = p234 +      ; ctrl1 = p34 +      ; p1 } ) + + +let get_closest_point +  : Gg.v2 -> t -> float * Gg.v2 +  = fun point t -> + +    let rec f min max t = + +      (* First devide the curve in two *) +      let seq_0, seq_1 = slice 0.5 t in +      let avg = (min +. max) /. 2. in + +      let p0 = t.p0 +      and p1 = t.p1 +      and p01 = seq_0.p1 in (* seq_0.p1 = seq_1.p0 *) + +      let open Gg.V2 in +      let center0 = mix p0 p01 0.5 +      and center1 = mix p01 p1 0.5 in + +      if Tools.Utils.equal_point 0.001 p0 p1 then +        avg, p01 +      else if (norm (point - center0)) < (norm (point - center1)) then +        f min avg seq_0 +      else +        f avg max seq_1 + +    in f 0. 1. t + +let reverse +  : t -> t +  = fun bezier -> +    { +      p0 = bezier.p1 +    ; p1 = bezier.p0 +    ; ctrl0 = bezier.ctrl1 +    ; ctrl1 = bezier.ctrl0 } + +(** + +   see https://github.com/Pomax/BezierInfo-2/blob/master/docs/js/graphics-element/lib/bezierjs/bezier.js#L504 + +   let root +   : t -> 'a +   = fun bezier -> + +    let accept +      : float -> bool +      = fun t -> +        0. <= t && t <= 1. in + +    let cuberoot v = +      if v < 0.  then +        Float.pow (Float.neg v) ( 1. /. 3.) +        |> Float.neg +      else Float.pow v (1. /. 3.) in + + + + +    failwith "Non implemented" +*) diff --git a/script.it/shapes/bezier.mli b/script.it/shapes/bezier.mli new file mode 100755 index 0000000..2f5bbcf --- /dev/null +++ b/script.it/shapes/bezier.mli @@ -0,0 +1,40 @@ +type t = +  { p0:Gg.v2      (* The starting point *) +  ; p1:Gg.v2      (* The end point *) +  ; ctrl0:Gg.v2   (* The control point *) +  ; ctrl1:Gg.v2 } (* The control point *) + +type quadratic + +(** +   Build a control point for a quadratic curve for passing throuht 3 points. +   taken from https://xuhehuan.com/2608.html + + +   also look to https://pomax.github.io/bezierinfo/#pointcurves +*) +val three_points_quadratic +  : Gg.v2 -> Gg.v2 -> Gg.v2 -> quadratic + +(** +   Create a curve from three points. + +   This is an implementation for +   https://pomax.github.io/bezierinfo/#pointcurves + +*) +val three_points_cubic +  : float -> Gg.v2 -> Gg.v2 -> Gg.v2 -> t + +val quadratic_to_cubic +  : quadratic -> t + +(** Split a bezier curve in two at a given position *) +val slice +  : float -> t -> t * t + +(** Return the closest point to the curve by approximation *) +val get_closest_point +  : Gg.v2 -> t -> float * Gg.v2 + +val reverse: t -> t diff --git a/script.it/shapes/bspline.ml b/script.it/shapes/bspline.ml new file mode 100755 index 0000000..bb60227 --- /dev/null +++ b/script.it/shapes/bspline.ml @@ -0,0 +1,149 @@ +open StdLabels + +type err = [`InvalidPath ] + +module M = Matrix.MakeMatrix (struct + +    type t = Float.t + +    let compare a b = + +      let v = Float.compare a b in +      if v = 0 then Matrix.Order.Equal +      else if v > 0 then Matrix.Order.Greater +      else Matrix.Order.Less + +    let zero = Float.zero +    let one = Float.one + +    let divide = (/.) +    let multiply = ( *. ) +    let add = (+.) +    let subtract = (-.) +    exception NonElt + + +  end) + +type t = Gg.v2 list + +let from_points +  : Gg.v2 array -> (Gg.v2 array, [> `InvalidPath]) Result.t +  = fun points -> + +    let n = (Array.length points - 2) in + +    if n <= 1 then +      Result.error `InvalidPath +    else + +      (* Create the initial matrix. + +         The matrix is augmented with two additionals columns, which will be +         populated with the points from the path. +      *) +      let arr = Array.init n ~f:(fun line -> +          Array.init (n +2) ~f:(fun row -> +              match row - line with +              | (-1) -> 1. +              | 0 -> 4. +              | 1 -> 1. +              | _ -> 0. +            ) +        ) in +      let matrix = M.from_array arr in + +      (* Add the points from the augmented matrix *) +      let points_array = points in +      for line = 0 to (n -1) do + +        let point = +          if line = 0 then +            let p0 = points_array.(0) +            and p1 = points_array.(1) in +            Gg.V2.(6. * p1 - p0) +          else if (line + 1) = n  then +            let p_n_2 = points_array.(n) +            and p_n_1 = points_array.(n + 1) in +            Gg.V2.(6. * p_n_2 - p_n_1) +          else +            let n' = line + 1 in +            Gg.V2.(6. * points_array.(n')) +        in +        let x = (Gg.V2.x point) +        and y = (Gg.V2.y point) in + + +        M.set_elt matrix (line + 1, n + 1) x; +        M.set_elt matrix (line + 1, n + 2) y; +      done; + +      (* Resolve the matrix *) +      let res' = M.row_reduce matrix in + +      (* Extract the result as points *) +      let _, col_x = M.get_column res' (n + 1) +      and _, col_y = M.get_column res' (n + 2) in + +      (* Build the result *) +      let res = Array.make (n + 2) (Array.get points_array (n + 1) ) in +      for i = 1 to n do +        let point = Gg.V2.v col_x.(i - 1) col_y.(i - 1) in +        Array.set res i point; +      done; +      Array.set res 0 (Array.get points_array 0); +      Result.ok res + +let (let*) = Result.bind + +(** Build a continue curve from path + +    see https://www.math.ucla.edu/~baker/149.1.02w/handouts/dd_splines.pdf +*) +let to_bezier +  : ?connexion0:Gg.v2 -> ?connexion1:Gg.v2 -> t -> (Bezier.t array, [> `InvalidPath]) Result.t +  = fun ?connexion0 ?connexion1 points -> + +    let points' = match connexion0 with +      | None -> points +      | Some pt -> pt::points in + +    let arr_points = match connexion1 with +      | None -> Array.of_list points' +      | Some pt -> +        let arr = Array.make (1 + (List.length points')) pt in +        List.iteri points' +          ~f:(fun i value -> Array.set arr i value); +        arr in + +    let* bspline_points = from_points arr_points in + +    let start = match connexion0 with +      | None -> 1 +      | Some _ -> 2 +    and end_ = match connexion1 with +      | None -> (Array.length bspline_points) - 1 +      | Some _ -> (Array.length bspline_points) - 2 in + +    let result = Array.init (end_ - start + 1) ~f:(fun i -> + +        let i = i + start in + +        let prev_b = Array.get bspline_points (i - 1) +        and bpoint = Array.get bspline_points i +        and prev_p = Array.get arr_points (i - 1) +        and point = Array.get arr_points i in +        let ctrl0 = Gg.V2.(mix prev_b bpoint (1. /. 3.)) +        and ctrl1 = Gg.V2.(mix prev_b bpoint (2. /. 3.)) in + +        let bezier = +          { Bezier.p0 = prev_p +          ; Bezier.p1 = point +          ; Bezier.ctrl0 +          ; Bezier.ctrl1 } in + +        bezier + +      ) in +    Result.Ok result + diff --git a/script.it/shapes/bspline.mli b/script.it/shapes/bspline.mli new file mode 100755 index 0000000..a36aa22 --- /dev/null +++ b/script.it/shapes/bspline.mli @@ -0,0 +1,24 @@ +type t + +type err =  +  [ `InvalidPath (* Too few points in the path for building the curve *) +  ] + +(** Convert a list of points into a beziers curves.  + +    At least 4 points are required for building the path. + +    [to_bezier ~connexion points] create a list of beziers segments joining all +    the points together.  + +    [connexion0] add a virtual point in the begining for helping to get the +    appropriate tangent when connecting path together + +    [connexion1] does the same at the end + +*) +val to_bezier +  :  ?connexion0:Gg.v2 +  -> ?connexion1:Gg.v2 +  -> Gg.v2 list  +  -> (Bezier.t array, [> err]) Result.t diff --git a/script.it/shapes/dd_splines.pdf b/script.it/shapes/dd_splines.pdfBinary files differ new file mode 100755 index 0000000..2618162 --- /dev/null +++ b/script.it/shapes/dd_splines.pdf diff --git a/script.it/shapes/dune b/script.it/shapes/dune new file mode 100755 index 0000000..d03a217 --- /dev/null +++ b/script.it/shapes/dune @@ -0,0 +1,7 @@ +(library + (name shapes) + (libraries  +   tools +   matrix +   ) + ) diff --git a/script.it/shapes/matrix/EltsI.ml b/script.it/shapes/matrix/EltsI.ml new file mode 100755 index 0000000..fcfdb50 --- /dev/null +++ b/script.it/shapes/matrix/EltsI.ml @@ -0,0 +1,28 @@ +module type ORDERED_AND_OPERATIONAL = +sig + +  (* Exception for from_string. Is raised when from_string is passed something +   * that is not an elt *) +  exception NonElt + +  type t + +  (* The zero element *) +  val zero : t + +  (* The one element *) +  val one: t + +  (* ts must be comparable *) +  val compare : t -> t -> Order.order + +  (* Basic mathematical operations must be possible *) +  val add: t -> t -> t + +  val subtract: t -> t -> t + +  val multiply: t -> t -> t + +  val divide: t -> t -> t + +end diff --git a/script.it/shapes/matrix/Helpers.ml b/script.it/shapes/matrix/Helpers.ml new file mode 100755 index 0000000..6980052 --- /dev/null +++ b/script.it/shapes/matrix/Helpers.ml @@ -0,0 +1,16 @@ +(* Takes in a string and a separator, and separates the string into a list of + * substrings where each substring is between two separators or between a + * separator and the beginning/end of the string *) +let explode (s: string) (space: string) : string list = +  let rec build (curr: string) (buffer: string) (lst: string list) : string list = +    let len = String.length curr in +    if len = 0 then buffer::lst +    else  +      let c = String.sub curr (len - 1) 1 in +      if len = 1 then (c ^ buffer)::lst +      else  +        let s' = String.sub curr 0 (len - 1) in +        if c = space then build s' "" (buffer::lst) +        else build s' (c ^ buffer) lst in +  build (String.trim s) "" [] + diff --git a/script.it/shapes/matrix/Matrix.ml b/script.it/shapes/matrix/Matrix.ml new file mode 100755 index 0000000..7f1d54b --- /dev/null +++ b/script.it/shapes/matrix/Matrix.ml @@ -0,0 +1,529 @@ +open Order + +module Order = Order + +(*************** Exceptions ***************) + +exception NonSquare +exception ImproperDimensions + +(* Functor so we can Abstract away! *) +module MakeMatrix (C: EltsI.ORDERED_AND_OPERATIONAL) : +  (MatrixI.MATRIX with type elt = C.t) = +struct + + +  (*************** End Exceptions ***************) + +  (*************** Types ***************) + +  type elt = C.t + +  (* A matrix is a pair of dimension (n x p) and a array of arrays +   * the first array is the row (n) and the second the column (p) *) +  type matrix = (int * int) * (elt array array) + +  (*************** End Types ***************) + +  (*************** Base Functions ***************) + +  (* catching negative dimensions AND 0 dimensions and too large +   * of a dimension so we don't have to worry about it later *) +  let empty (rows: int) (columns: int) : matrix = +    if rows > 0 && columns > 0 then +      try +        let m = Array.make_matrix rows columns C.zero in ((rows,columns),m) +      with _ -> +        raise ImproperDimensions +    else (* dimension is negative or 0 *) +      raise ImproperDimensions + +  (*************** End Base Functions ***************) + +  (*************** Helper Functions ***************) + +  (* get's the nth row of a matrix and returns (r, row) where r is the length +   * of the row and row is a COPY of the original row. For example, calling +   * calling get_row m 1 will return (3, |1 3 4 |) +   *         ________ +   *    m = | 1 3 4 | +   *        |*2 5 6 | +  *) +  (* aside: we don't check whether n < 1 because of our matrix invariant *) +  let get_row (((n,p),m): matrix) (row: int) : int * elt array = +    if row <= n then +      let row' = Array.map (fun x -> x) m.(row - 1) in +      (p, row') +    else +      raise (Failure "Row out of bounds.") + +  (* similar to get_row. For m, get_column m 1 will return (2, |1 2|) *) +  let get_column (((n,p),m): matrix) (column: int) : int * elt array = +    if column <= p then +      begin +        let column' = Array.make n C.zero in +        for i = 0 to n - 1 do +          column'.(i) <- m.(i).(column - 1) +        done; +        (n, column') +      end +    else +      raise (Failure "Column out of bounds.") + +  (* sets the nth row of the matrix m to the specified array a. +   * This is done IN-PLACE. Therefore the function returns unit.  You should +   * nonetheless enfore immutability whenever possible.  For a clarification on +   * what nth row means, look at comment for get_row above. *) +  let set_row (((n, p), m): matrix) (row: int) (a: elt array) : unit = +    if row <= n then +      begin +        assert(Array.length a = p); +        for i = 0 to p - 1 do +          m.(row - 1).(i) <- a.(i) +        done; +      end +    else +      raise (Failure "Row out of bounds.") + +  (* Similar to set_row but sets the nth column instead *) +  let set_column (((n,p),m): matrix) (column: int) (a: elt array) : unit = +    if column <= p then +      begin +        assert(Array.length a = n); +        for i = 0 to n - 1 do +          m.(i).(column - 1) <- a.(i) +        done; +      end +    else +      raise (Failure "Column out of bounds.") + +  (* returns the ij-th element of a matrix (not-zero indexed) *) +  let get_elt (((n,p),m): matrix) ((i,j): int*int) : elt = +    if i <= n && j <= p then +      m.(i - 1).(j - 1) +    else +      raise ImproperDimensions + +  (* Changes the i,j-th element of a matrix to e. Is not zero-indexed, and +   * changes the matrix in place *) +  let set_elt (((n,p),m): matrix) ((i,j): int*int) (e: elt) : unit = +    if i <= n && j <= p then +      m.(i - 1).(j - 1) <- e +    else +      raise ImproperDimensions + +  (* similar to map, but applies to function to the entire matrix +   * Returns a new matrix *) +  let map (f: elt -> elt) (mat: matrix) : matrix = +    let (dim,m) = mat in +    (dim, Array.map (Array.map f) m) + +  (* Just some wrapping of Array.iter made for Matrices! *) +  let iter (f: elt -> unit) (mat: matrix) : unit = +    let _, m = mat in +    Array.iter (Array.iter f) m + +  (* Just some wrapping of Array.iteri. Useful for pretty +   * printing matrix. The index is (i,j). NOT zero-indexed *) +  let iteri (f: int -> int -> elt -> unit) (mat: matrix) : unit = +    let _, m = mat in +    Array.iteri (fun i row -> Array.iteri (fun j e -> f i j e) row) m + +  (* folds over each row using base case u and function f *) +  (* could be a bit more efficient? *) +  let reduce (f: 'a -> elt -> 'a) (u: 'a) (((p,q),m): matrix) : 'a = +    let total = ref u in +    for i = 0 to p - 1 do +      for j = 0 to q - 1 do +        total := f (!total) m.(i).(j) +      done; +    done; +    !total + +  let fold_row ~(f: elt array -> 'b) ((_,m): matrix) : 'b list = + +    let call_row acc v = (f v)::acc in +    Array.fold_left call_row [] m +    |> List.rev + + + + +  (* given two arrays, this will calculate their dot product *) +  (* It seems a little funky, but this is done for efficiency's sake. +   * In short, it tries to multiply each element by it's respective +   * element until the one array is indexed out of bounds. If the +   * other array is also out of bounds, then it returns their value. +   * Otherwise, the arrays were the wrong size and raises ImproperDimension + +     THE ABOVE COMMENT HAS NOT BEEN IMPLEMENTED + +     Instead we calculate the length before starting +  *) +  let dot (v1: elt array) (v2: elt array) : elt = +    let rec dotting (i: int) (total: elt) : elt = +      if i = 0 then total +      else +        let curr = C.multiply v1.(i-1) v2.(i-1) in +        dotting (i - 1) (C.add curr total) in +    let len1, len2 = Array.length v1, Array.length v2 in +    if len1 = len2 then dotting len1 C.zero +    else raise ImproperDimensions + +  (* function to expose the dimensions of a matrix *) +  let get_dimensions (m: matrix) : (int * int) = +    let ((x,y), _) = m in (x,y) + +  (*************** End Helper Functions ***************) + + +  (*************** Primary Matrix Functions ***************) + +  (* scales a matrix by the appropriate factor *) +  let scale (m: matrix) (sc: elt) : matrix = map (C.multiply sc) m + +  (* Generates a matrix from a list of lists. The inners lists are the rows *) +  let from_list (lsts : elt list list) : matrix = +    let check_length (length: int) (lst: elt list) : int = +      if List.length lst = length then length +      else raise ImproperDimensions in +    let p = List.length lsts in +    match lsts with +    | [] -> raise ImproperDimensions +    | hd::tl -> +      let len = List.length hd in +      if List.fold_left check_length len tl = len then +        ((p,len),Array.map Array.of_list (Array.of_list lsts)) +      else +        raise ImproperDimensions + +  (* Generates a matrix from a list of lists. The inners lists are the rows *) +  let from_array (arrs : elt array array) : matrix = +    let check_length (length: int) (arr: elt array) : unit = +      if Array.length arr = length then () +      else raise ImproperDimensions in +    let p = Array.length arrs in +    match Array.length arrs with +    | 0 -> raise ImproperDimensions +    | _ -> +      let len = Array.length (Array.get arrs 0) in +      Array.iter (check_length len) arrs; +      ((p, len), arrs) + +  (* Adds two matrices. They must have the same dimensions *) +  let add ((dim1,m1): matrix) ((dim2,m2): matrix) : matrix = +    if dim1 = dim2 then +      let n, p = dim1 in +      let (dim', sum_m) = empty n p in +      for i = 0 to n - 1 do +        for j = 0 to p - 1 do +          sum_m.(i).(j) <- C.add m1.(i).(j) m2.(i).(j) +        done; +      done; +      (dim',sum_m) +    else +      raise ImproperDimensions + + +  (* Multiplies two matrices. If the matrices have dimensions m x n and p x q, n +   * and p must be equal, and the resulting matrix will have dimension n x q *) +  let mult (matrix1: matrix) (matrix2: matrix) : matrix = +    let ((m,n), _), ((p,q), _) = matrix1, matrix2 in +    if n = p then +      let (dim, result) = empty m q in +      for i = 0 to m - 1 do +        for j = 0 to q - 1 do +          let (_,row), (_,column) = get_row matrix1 (i + 1), +                                    get_column matrix2 (j + 1) in +          result.(i).(j) <- dot row column +        done; +      done; +      (dim,result) +    else +      raise ImproperDimensions + +  (*************** Helper Functions for Row Reduce ***************) + +  (* +  (* returns the index of the first non-zero elt in an array*) +  let zero (arr: elt array) : int option = +    let index = ref 1 in +    let empty (i: int option) (e: elt) : int option = +      match i, C.compare e C.zero with +      | None, Equal -> (index := !index + 1; None) +      | None, _ -> Some (!index) +      | _, _ -> i in +    Array.fold_left empty None arr + +  (* returns the the location of the nth non-zero +   * element in the matrix. Scans column wise.  So the nth non-zero element is +   * the FIRST non-zero element in the nth non-zero column *) +  let nth_nz_location (m: matrix) (_: int): (int*int) option = +    let ((n,p), _) = m in +    let rec check_col (to_skip: int) (j: int) = +      if j <= p then +        let (_,col) = get_column m j in +        match zero col with +        | None -> check_col to_skip (j + 1) +        | Some i -> +          if to_skip = 0 then +            Some (i,j) +          else (* we want a later column *) +            check_col (to_skip - 1) (j + 1) +      else None in +    check_col (n - 1) 1 + +  (* returns the the location of the first +   * non-zero and non-one elt. Scans column wise, from +   * left to right. Basically, it ignores columns +   * that are all zero or that *) +  let fst_nz_no_loc (m: matrix): (int*int) option = +    let ((_, p), _) = m in +    let rec check_col (j: int) = +      if j <= p then +        let (_,col) = get_column m j in +        match zero col with +        | None -> check_col (j + 1) +        | Some i -> +          match C.compare col.(i-1) C.one with +          | Equal -> check_col (j + 1) +          | _ -> Some (i,j) +      else None in +    check_col 1 +    *) + +  (* Compares two elements in an elt array and returns the greater and its +   * index. Is a helper function for find_max_col_index *) +  let compare_helper (e1: elt) (e2: elt) (ind1: int) (ind2: int) : (elt*int) = +    match C.compare e1 e2 with +    | Equal -> (e2, ind2) +    | Greater -> (e1, ind1) +    | Less -> (e2, ind2) + +  (* Finds the element with the greatest absolute value in a column. Is not +   * 0-indexed. If two elements are both the maximum value, returns the one with +   * the lowest index. Returns None if this element is zero (if column is all 0) +  *) +  let find_max_col_index (array1: elt array) (start_index: int) : int option = +    let rec find_index (max_index: int) (curr_max: elt) (curr_index: int) +        (arr: elt array) = +      if curr_index = Array.length arr then +        (if curr_max = C.zero then None +         else Some (max_index+1)) (* Arrays are 0-indexed but matrices aren't *) +      else +        (match C.compare arr.(curr_index) C.zero with +         | Equal -> find_index max_index curr_max (curr_index+1) arr +         | Greater -> +           (let (el, index) = compare_helper (arr.(curr_index)) +                curr_max curr_index max_index in +            find_index index el (curr_index+1) arr) +         | Less -> +           (let abs_curr_elt = C.subtract C.zero arr.(curr_index) in +            let (el, index) = compare_helper abs_curr_elt curr_max curr_index +                max_index in +            find_index index el (curr_index+1) arr)) +    in +    find_index 0 C.zero (start_index -1) array1 + +  (* Basic row operations *) +  (* Scales a row by sc *) +  let scale_row (m: matrix) (num: int) (sc: elt) : unit = +    let (_, row) = get_row m num in +    let new_row = Array.map (C.multiply sc) row in +    set_row m num new_row + +  (* Swaps two rows of a matrix *) +  let swap_row (m: matrix) (r1: int) (r2: int) : unit = +    let (len1, row1) = get_row m r1 in +    let (len2, row2) = get_row m r2 in +    let _ = assert (len1 = len2) in +    let _ = set_row m r1 row2 in +    let _ = set_row m r2 row1 in +    () + +  (* Subtracts a multiple of r2 from r1 *) +  let sub_mult (m: matrix) (r1: int) (r2: int) (sc: elt) : unit = +    let (len1, row1) = get_row m r1 in +    let (len2, row2) = get_row m r2 in +    let _ = assert (len1 = len2) in +    for i = 0 to len1 - 1 do (* Arrays are 0-indexed *) +      row1.(i) <- C.subtract row1.(i) (C.multiply sc row2.(i)) +    done; +    set_row m r1 row1 + +  (*************** End Helper Functions for Row Reduce ***************) + +  (* Returns the row reduced form of a matrix. Is not done in place, but creates +   * a new matrix *) +  let row_reduce (mat: matrix) : matrix = +    let[@tailcall] rec row_reduce_h (n_row: int) (n_col: int) (mat2: matrix) : unit = +      let ((num_row, _), _) = mat2 in +      if (n_col = num_row + 1) then () +      else +        let (_,col) = get_column mat2 n_col in +        match find_max_col_index col n_row with +        | None (* Column all 0s *) -> row_reduce_h n_row (n_col+1) mat2 +        | Some index -> +          begin +            swap_row mat2 index n_row; +            let pivot = get_elt mat2 (n_row, n_col) in +            scale_row mat2 (n_row) (C.divide C.one pivot); +            for i = 1 to num_row do +              if i <> n_row then sub_mult mat2 i n_row (get_elt mat2 (i,n_col)) +            done; +            row_reduce_h (n_row+1) (n_col+1) mat2 +          end +    in +    (* Copies the matrix *) +    let ((n,p),m) = mat in +    let (dim,mat_cp) = empty n p in +    for i = 0 to n - 1 do +      for j = 0 to p - 1 do +        mat_cp.(i).(j) <- m.(i).(j) +      done; +    done; +    let _ = row_reduce_h 1 1 (dim,mat_cp) in (dim,mat_cp) + +  (*************** End Main Functions ***************) + +  (*************** Optional module functions ***************) + +  (* calculates the trace of a matrix *) +  let trace (((n,p),m): matrix) : elt = +    let rec build (elt: elt) (i: int) = +      if i > -1 then +        build (C.add m.(i).(i) elt) (i - 1) +      else +        elt in +    if n = p then build C.zero (n - 1) +    else raise ImproperDimensions + +  (* calculates the transpose of a matrix and retuns a new one *) +  let transpose (((n,p),m): matrix) = +    let (dim,m') = empty p n in +    for i = 0 to n - 1 do +      for j = 0 to p - 1 do +        m'.(j).(i) <- m.(i).(j) +      done; +    done; +    assert(dim = (p,n)); +    ((p,n),m') + +  (* Returns the inverse of a matrix. Uses a pretty simple algorithm *) +  let inverse (mat: matrix) : matrix = +    let ((n, p), _) = mat in +    if n = p then +      (* create augmented matrix *) +      let augmented = empty n (2*n) in +      for i = 1 to n do +        let (dim,col) = get_column mat i in +        let arr = Array.make n C.zero in +        begin +          assert(dim = n); +          arr.(i-1) <- C.one; +          set_column augmented i col; +          set_column augmented (n + i) arr +        end +      done; +      let augmented' = row_reduce augmented in +      (* create the inverted matrix and fill in with appropriate values *) +      let inverse = empty n n in +      for i = 1 to n do +        let (dim, col) = get_column augmented' (n + i) in +        let _ = assert(dim = n) in +        let _ = set_column inverse i col in +        () +      done; +      inverse +    else +      raise NonSquare + +  (***************** HELPER FUNCTIONS FOR DETERMINANT *****************) +  (* creates an identity matrix of size n*) +  let create_identity (n:int) : matrix = +    let (dim,m) = empty n n in +    for i = 0 to n - 1 do +      m.(i).(i) <- C.one +    done; +    (dim,m) + +  (* Finds the index of the maximum value of an array *) +  let find_max_index (arr: elt array) (start_index : int) : int = +    let rec find_index (max_index: int) (curr_index: int) = +      if curr_index = Array.length arr then max_index+1 +      else +        match C.compare arr.(curr_index) arr.(max_index) with +        | Equal | Less -> find_index max_index (curr_index + 1) +        | Greater -> find_index curr_index (curr_index + 1) in +    find_index (start_index - 1) start_index + +  (* Creates the pivoting matrix for A. Returns swqps. Adapted from +   * http://rosettacode.org/wiki/LU_decomposition#Common_Lisp *) +  let pivotize (((n,p),m): matrix) : matrix * int = +    if n = p then +      let swaps = ref 0 in +      let pivot_mat = create_identity n in +      for j = 1 to n do +        let (_,col) = get_column ((n,p),m) j in +        let max_index = find_max_index col j in +        if max_index <> j then +          (swaps := !swaps + 1; swap_row pivot_mat max_index j) +        else () +      done; +      (pivot_mat,!swaps) +    else raise ImproperDimensions + +  (* decomposes a matrix into a lower triangualar, upper triangualar +   * and a pivot matrix. It returns (L,U,P). Adapted from +   * http://rosettacode.org/wiki/LU_decomposition#Common_Lisp *) +  let lu_decomposition (((n,p),m): matrix) : (matrix*matrix*matrix)*int = +    if n = p then +      let mat = ((n,p),m) in +      let lower, upper, (pivot,s) = empty n n, empty n n, pivotize mat in +      let (_ ,l),(_ ,u), _ = lower,upper,pivot in +      let ((_, _),mat') = mult pivot mat in +      for j = 0 to n - 1 do +        l.(j).(j) <- C.one; +        for i = 0 to j do +          let sum = ref C.zero in +          for k = 0 to i - 1 do +            sum := C.add (!sum) (C.multiply u.(k).(j) l.(i).(k)) +          done; +          u.(i).(j) <- C.subtract mat'.(i).(j) (!sum) +        done; +        for i = j to n - 1 do +          let sum = ref C.zero in +          for k = 0 to j - 1 do +            sum := C.add (!sum) (C.multiply u.(k).(j) l.(i).(k)) +          done; +          let sub = C.subtract mat'.(i).(j) (!sum) in +          l.(i).(j) <- C.divide sub u.(j).(j) +        done; +      done; +      (lower,upper,pivot),s +    else raise ImproperDimensions + +  (* Computes the determinant of a matrix *) +  let determinant (m: matrix) : elt = +    try +      let ((n,p), _) = m in +      if n = p then +        let rec triangualar_det (a,mat) curr_index acc = +          if curr_index < n then +            let acc' = C.multiply mat.(curr_index).(curr_index) acc in +            triangualar_det (a,mat) (curr_index + 1) acc' +          else acc in +        let ((dim1,l),(dim2,u), _),s = lu_decomposition m in +        let det1, det2 = triangualar_det (dim1,l) 0 C.one, +                         triangualar_det (dim2,u) 0 C.one in +        if s mod 2 = 0 then C.multiply det1 det2 +        else C.subtract C.zero (C.multiply det1 det2) +      else raise ImproperDimensions +    with +    | _ -> C.zero + + +  (*************** Optional module functions ***************) + + +end diff --git a/script.it/shapes/matrix/MatrixI.ml b/script.it/shapes/matrix/MatrixI.ml new file mode 100755 index 0000000..fbc4e21 --- /dev/null +++ b/script.it/shapes/matrix/MatrixI.ml @@ -0,0 +1,105 @@ +exception NonSquare +exception ImproperDimensions + +module type MATRIX = +sig + +  (******** TYPES ********) +  type elt + +  type matrix + +  (* empty matrix of nxp dimensions *) +  val empty : int -> int -> matrix + +  (* Takes a list of lists and converts that to a matrix *) +  val from_list : (elt list list) -> matrix + +  val from_array: elt array array -> matrix + +  (******** OPERATIONS ON ONE MATRIX ********) +  (* Takes in a matrix and returns its dimensions. ie, nxp *) +  val get_dimensions : matrix -> (int * int) + +  (* get's the row of a matrix: Not zero-indexed. *) +  val get_row : matrix -> int -> (int * elt array) + +  (* similar to get_row *) +  val get_column: matrix -> int -> (int * elt array) + +  (* sets the row of a matrix in place! Not zero-index *) +  val set_row: matrix -> int -> elt array -> unit + +  (* similar to set_row, but for a column *) +  val set_column: matrix -> int -> elt array -> unit + +  (* gets the element at the specified index. *) +  val get_elt: matrix -> (int * int) -> elt + +  (* sets the element at the specified index *) +  val set_elt: matrix -> (int * int) -> elt -> unit + +  (* Scales every element in the matrix by another elt *) +  val scale : matrix -> elt -> matrix + + +  (******** MORE ADVANCED SINGLE MATRIX OPERATIONS ********) +  (* Returns the row reduced form of a matrix *) +  val row_reduce: matrix -> matrix +  (* We will implement the algorithm found in the link above *) + +  (* Returns the inverse of a matrix *) +  val inverse: matrix -> matrix + +  (*Transposes a matrix. If the input has dimensions m x n, the output will +   * have dimensions n x m *) +  val transpose: matrix -> matrix + +  (* Returns the trace of the matrix *) +  val trace: matrix -> elt + +  (******** OPERATIONS ON TWO MATRICES ********) +  (* Adds two matrices. They must have the same dimensions *) +  val add : matrix -> matrix -> matrix + +  (* Multiplies two matrices. If the matrices have dimensions m x n and p x q, n +   * and p must be equal, and the resulting matrix will have dimension m x q *) +  val mult: matrix -> matrix -> matrix + +  (**** Other Library Functions ***) +  (* Function to make over our matrices *) +  val map : (elt -> elt) -> matrix -> matrix + +  (*val iter : (elt -> unit) -> matrix -> unit*) + +  (* Returns the LUP decomposition of a matrix *) +  val lu_decomposition : matrix -> (matrix * matrix * matrix) * int + +  (* Returns the determinant of the matrix *) +  val determinant: matrix -> elt + +  (************** Other Library Functions *************) +  val iter : (elt -> unit) -> matrix -> unit + +  val iteri : (int -> int -> elt -> unit) -> matrix -> unit + +  (* folds over each row using base case u and function f *) +  val reduce: ('a -> elt -> 'a) -> 'a -> matrix -> 'a + +  val fold_row: f:(elt array -> 'b) -> matrix -> 'b list + +  (********** Specific for Simplex Algorithm ***********) +  (** All of the following functions will raise ImproperDimensions +   * Exception if the matrix is not the right size for the operation +   **) + +  (* Scales a row *) +  val scale_row: matrix -> int -> elt -> unit + +  (* Swaps two rows *) +  val swap_row: matrix -> int -> int -> unit + +  (* Subtracts a multiple of one row (the 2nd int) from another (the 1st int) *) +  val sub_mult: matrix -> int -> int -> elt -> unit + +end diff --git a/script.it/shapes/matrix/Order.ml b/script.it/shapes/matrix/Order.ml new file mode 100755 index 0000000..5f2aa22 --- /dev/null +++ b/script.it/shapes/matrix/Order.ml @@ -0,0 +1,2 @@ +(* Defines a general ordering type *) +type order = Equal | Less | Greater diff --git a/script.it/shapes/matrix/dune b/script.it/shapes/matrix/dune new file mode 100755 index 0000000..1c0cab6 --- /dev/null +++ b/script.it/shapes/matrix/dune @@ -0,0 +1,3 @@ +(library + (name matrix) +) diff --git a/script.it/shapes/tools/dune b/script.it/shapes/tools/dune new file mode 100755 index 0000000..a2c3fdb --- /dev/null +++ b/script.it/shapes/tools/dune @@ -0,0 +1,6 @@ +(library + (name tools) + (libraries  +   gg +   ) +  ) diff --git a/script.it/shapes/tools/utils.ml b/script.it/shapes/tools/utils.ml new file mode 100755 index 0000000..b8a473f --- /dev/null +++ b/script.it/shapes/tools/utils.ml @@ -0,0 +1,63 @@ +open Gg.V2 + +let norm_angle vect = +  mod_float +    ((angle vect) +. Gg.Float.two_pi) +    Gg.Float.two_pi + + +let intersection +  : (Gg.v2 * Gg.v2) -> (Gg.v2 * Gg.v2) -> Gg.v2 option +  = fun (p0, p1) (p2, p3) -> +    let i = p1 - p0 +    and j = p3 - p2 in + +    let d = (x i *. y j) -. (y i *. x j) in +    if Float.( (abs d) <= 0.01 ) then +      None +    else +      let m = ((x i) *. (y p0) +               -. (x i) *. (y p2) +               -. (y i) *. (x p0) +               +. (y i) *. (x p2)) /. d in +      Some (p2 + m * j) +      (* +      let k = ((x j) *. (y p0) +               -. (x j) *. (y p2) +               -. (y j) *. (x p0) +               +. (y j) *. (x p2)) /. d in +      Some (p0 + k * i) +      *) + + +let center +  : Gg.v2 -> Gg.v2 -> Gg.v2 -> Gg.v2 option +  = fun p0 p1 p2 -> +    (* deltas *) +    let d1 = p1 - p0 +    and d2 = p2 - p1 in + +    (* perpendiculars *) +    let d1p = ortho d1 +    and d2p = ortho d2 in + +    (* Chord midpoints *) +    let m1 = half (p0 + p1) +    and m2 = half (p1 + p2) in + +    (* midpoint offsets *) +    let m1n = m1 + d1p +    and m2n = m2 + d2p in + +    intersection (m1, m1n) (m2, m2n) + +let rotate +  : Gg.v2 -> float -> Gg.v2 +  = fun p0 theta -> +    let r = x (to_polar p0) in +    of_polar (v r theta) + +let equal_point +  : float -> Gg.v2 -> Gg.v2 -> bool +  = fun eps p0 p1 -> +    Gg.V2.equal_f (fun v0 v1 ->  (Float.abs (v1 -. v0)) <= eps ) p0 p1 diff --git a/script.it/shapes/tools/utils.mli b/script.it/shapes/tools/utils.mli new file mode 100755 index 0000000..4e12906 --- /dev/null +++ b/script.it/shapes/tools/utils.mli @@ -0,0 +1,21 @@ +(** Return a normalize angle *) +val norm_angle  +  : Gg.v2 -> float + +(** return the interesction for two segments *) +val intersection +  : (Gg.v2 * Gg.v2) -> (Gg.v2 * Gg.v2) -> Gg.v2 option + +(** Return the center of the cercle for three points   +    None if the point cannot be evaluated +*) +val center +  : Gg.v2 -> Gg.v2 -> Gg.v2 -> Gg.v2 option + +(** Rotate the vector by the given angle *) +val rotate +  : Gg.v2 -> float -> Gg.v2 + +(** Test equality between two points *) +val equal_point +  : float -> Gg.v2 -> Gg.v2 -> bool | 
