diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml new file mode 100644 index 0000000..95a2abb --- /dev/null +++ b/.github/workflows/build.yml @@ -0,0 +1,43 @@ +name: Builds, tests & co + +on: + - push + - pull_request + +permissions: read-all + +jobs: + build: + runs-on: ${{ matrix.os }} + + strategy: + matrix: + os: + - ubuntu-latest + - macos-latest + - windows-latest + fail-fast: false + + steps: + - name: Checkout tree + uses: actions/checkout@v6 + + - name: Set-up OCaml + uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: 5 + + - run: opam install . --deps-only --with-test + + - run: opam exec -- dune build + + - run: opam exec -- dune runtest + + lint-fmt: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: 5 + - uses: ocaml/setup-ocaml/lint-fmt@v3 # Check ocamlformat \ No newline at end of file diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..caa5329 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,3 @@ +profile = default +version = 0.29.0 +version-check = false diff --git a/dune-project b/dune-project index f9a4062..a6bbb3a 100644 --- a/dune-project +++ b/dune-project @@ -1,3 +1,50 @@ -(lang dune 1.0) +(lang dune 2.9) (name plotkicadsch) -(version 0.4.0) \ No newline at end of file +(generate_opam_files true) + +(package + (name plotkicadsch) + (synopsis "A command line tool to plot and compare KiCad schematics") + (description "plotkicadsch lets you export Kicad schematics to SVG, up to version 9, while plotgitsch lets you compare git revisions of the schematic pages") + (authors "Jean-Noël Avila ") + (maintainers "Jean-Noël Avila ") + (bug_reports "https://github.com/jnavila/plotkicadsch/issues") + (version 0.4.0) + (source (uri "git+https://github.com/jnavila/plotkicadsch")) + (homepage "https://github.com/jnavila/plotkicadsch") + (license GPL-2.0-or-later) + (depends + ocaml + base64 + kicadsch + digestif + dune + cmdliner + lwt_ppx + ppx_deriving + tyxml + git-unix + sha + ) +) +(package + (name kicadsch) + (synopsis "A library to parse KiCad schematics") + (description "kicadsch is a library to parse KiCad schematics, up to version 9") + (authors "Jean-Noël Avila ") + (maintainers "Jean-Noël Avila ") + (bug_reports "https://github.com/jnavila/plotkicadsch/issues") + (version 0.4.0) + (source (uri "git+https://github.com/jnavila/plotkicadsch")) + (homepage "https://github.com/jnavila/plotkicadsch") + (license GPL-2.0-or-later) + (depends + ocaml + uuidm + dune + csexp + ppx_deriving + ppx_inline_test + parsexp + ounit2 + )) diff --git a/kicadsch.opam b/kicadsch.opam index ac8bf9d..7ff0d4a 100644 --- a/kicadsch.opam +++ b/kicadsch.opam @@ -1,28 +1,39 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "Jean-Noël Avila " -authors: "Jean-Noël Avila " -homepage: "https://jnavila.github.io/plotkicadsch/" -doc: "https://jnavila.github.io/plotkicadsch/index" -synopsis: "Library to read and convert Kicad Sch files" -description: """ -Library able to read Kicad libraries and sch file and -drive a painter to paint the schematics. -""" +version: "0.4.0" +synopsis: "A library to parse KiCad schematics" +description: + "kicadsch is a library to parse KiCad schematics, up to version 9" +maintainer: ["Jean-Noël Avila "] +authors: ["Jean-Noël Avila "] +license: "GPL-2.0-or-later" +homepage: "https://github.com/jnavila/plotkicadsch" bug-reports: "https://github.com/jnavila/plotkicadsch/issues" -license: "ISC" -dev-repo: "git+https://github.com/jnavila/plotkicadsch.git" -build: [ - [ "dune" "subst" ] {dev} - [ "dune" "build" "-p" name "-j" jobs ] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} -] depends: [ - "ppx_inline_test" {with-test} + "ocaml" "uuidm" - "parsexp" + "dune" {>= "2.9"} + "csexp" "ppx_deriving" - "dune" {>= "1.0"} - "ounit" {with-test} - "ocaml" {>="4.07"} + "ppx_inline_test" + "parsexp" + "ounit2" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "--promote-install-files=false" + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["dune" "install" "-p" name "--create-install-files" name] ] -available: arch != "arm32" & arch != "x86_32" +dev-repo: "git+https://github.com/jnavila/plotkicadsch" diff --git a/kicadsch/src/dune b/kicadsch/src/dune index 1939adc..4aa1087 100644 --- a/kicadsch/src/dune +++ b/kicadsch/src/dune @@ -1,15 +1,10 @@ (library - (preprocess (pps ppx_deriving.show ppx_deriving.ord)) - (name kicadsch) - (public_name kicadsch) - (modules_without_implementation kicadSch_sigs kicadDefs) - (synopsis "Library to plotting KiCAD schematics") - (libraries - angstrom - uuidm - sexp_decode - parsexp - base64 - ) - (flags (:standard -w -3 -safe-string)) - ) + (preprocess + (pps ppx_deriving.show ppx_deriving.ord)) + (name kicadsch) + (public_name kicadsch) + (modules_without_implementation kicadSch_sigs kicadDefs) + (synopsis "Library to plotting KiCAD schematics") + (libraries angstrom uuidm sexp_decode parsexp base64) + (flags + (:standard -w -3 -safe-string))) diff --git a/kicadsch/src/kicadLibParserV1.ml b/kicadsch/src/kicadLibParserV1.ml index a03651c..7b46b0c 100644 --- a/kicadsch/src/kicadLibParserV1.ml +++ b/kicadsch/src/kicadLibParserV1.ml @@ -1,22 +1,18 @@ open KicadDefs + (* open KicadSch_sigs *) open KicadLib_sigs let pin_orientation_of_string = function - | "L" -> - P_L - | "R" -> - P_R - | "U" -> - P_U - | "D" -> - P_D - | s -> - failwith ("pin orientation mismatch " ^ s) + | "L" -> P_L + | "R" -> P_R + | "U" -> P_U + | "D" -> P_D + | s -> failwith ("pin orientation mismatch " ^ s) type t = component Lib.t * component option * elt list -let lib () = (Lib.create 256, None, []) +let lib () = (Lib.create 256, None, []) let get_comp_lib (lib, _, _) = lib open Schparse @@ -25,185 +21,160 @@ let parse_def = create_lib_parse_fun ~name:"component header" ~regexp_str:"DEF %s %s 0 %d %[YN] %[YN] %d %[FL] %[NP]" ~processing:(fun name _ _ dpnum dpname unit_count _ _ -> - let draw_pnum = dpnum.[0] = 'Y' in - let draw_pname = dpname.[0] = 'Y' in - let nname = - if name.[0] = '~' then String.sub name 1 (String.length name - 1) - else name - in - let multi = if unit_count = 1 then false else true in - Some (nname, draw_pnum, draw_pname, multi) ) - - (** Parsing component drawing primitives **) - - (** Parse a poly line - P Nb parts convert thickness x0 y0 x1 y1 xi yi cc - **) - let rec make_double ol il = - match il with - | [] -> - ol - | [_] -> - failwith "make double: odd number of coords!" - | x :: y :: tl -> - make_double (RelCoord (x, y) :: ol) tl - - let parse_integers = parse_list " %d " - - let parse_Poly = - create_lib_parse_fun ~name:"polygon" ~regexp_str:"P %d %d %d %d %s@@" - ~processing:(fun _ parts _ thickness remainder -> - let coords = List.rev (parse_integers remainder) in - let finish = remainder.[String.length remainder - 1] = 'F' in - let coord_list = make_double [] coords in - let corner_list = - if finish then - match coord_list with - | [_] | [] -> - coord_list - | c :: _ -> - c :: List.rev coord_list - else List.rev coord_list - in - Some {parts; prim= Polygon (thickness, corner_list)} ) - - let parse_rect = - create_lib_parse_fun ~name:"rectangle" - ~regexp_str:"S %d %d %d %d %d %d %d %s" - ~processing:(fun x1 y1 x2 y2 parts _ thickness _ -> - try - let c1 = RelCoord (x1, y1) in - let c2 = RelCoord (x2, y2) in - let rect_poly = [c1; RelCoord (x1, y2); c2; RelCoord (x2, y1); c1] in - Some {parts; prim= Polygon (thickness, rect_poly)} - with _ -> None ) - - let parse_circle = - create_lib_parse_fun ~name:"circle" ~regexp_str:"C %d %d %d %d %d %d" - ~processing:(fun x y radius parts _ width -> - try - let center = RelCoord (x, y) in - Some {parts; prim= Circle (width, {center; radius})} - with _ -> None ) - - let parse_pin = - create_lib_parse_fun ~name:"pin" - ~regexp_str:"X %s %s %d %d %d %[RLUD] %d %d %d %d %s %s" - ~processing:(fun nm nb x y sz o nm_sz nb_sz parts _ _ c -> - if String.length c = 0 || c.[0] != 'N' then - try - let contact = RelCoord (x, y) in - let length = Size sz in - let orient = pin_orientation_of_string o in - let name = (nm, Size nm_sz) in - let number = (nb, Size nb_sz) in - Some {parts; prim= Pin {name; number; length; contact; orient}} - with _ -> None - else Some {parts= -1; prim= Field} ) - - let parse_alias = - create_lib_parse_fun ~name:"ALIAS" ~regexp_str:"ALIAS %s@@" - ~processing:(fun sp -> - Some (parse_list ~cond:(fun s -> String.length s > 0) " %s " sp) ) - - let parse_text = - create_lib_parse_fun ~name:"Text" ~regexp_str:"T %d %d %d %d %d %d %d %s" - ~processing:(fun _ x y sz _ parts _ text -> - let c = RelCoord (x, y) in - let s = Size sz in - Some {parts; prim= Text {c; text; s}} ) - - let parse_arc = - create_lib_parse_fun ~name:"Arc" - ~regexp_str:"A %d %d %d %d %d %d %d %d %s %d %d %d %d" - ~processing:(fun x y radius _ _ parts _ sz _ spx spy epx epy -> + let draw_pnum = dpnum.[0] = 'Y' in + let draw_pname = dpname.[0] = 'Y' in + let nname = + if name.[0] = '~' then String.sub name 1 (String.length name - 1) + else name + in + let multi = if unit_count = 1 then false else true in + Some (nname, draw_pnum, draw_pname, multi)) + +(** Parsing component drawing primitives **) + +(** Parse a poly line P Nb parts convert thickness x0 y0 x1 y1 xi yi cc **) +let rec make_double ol il = + match il with + | [] -> ol + | [ _ ] -> failwith "make double: odd number of coords!" + | x :: y :: tl -> make_double (RelCoord (x, y) :: ol) tl + +let parse_integers = parse_list " %d " + +let parse_Poly = + create_lib_parse_fun ~name:"polygon" ~regexp_str:"P %d %d %d %d %s@@" + ~processing:(fun _ parts _ thickness remainder -> + let coords = List.rev (parse_integers remainder) in + let finish = remainder.[String.length remainder - 1] = 'F' in + let coord_list = make_double [] coords in + let corner_list = + if finish then + match coord_list with + | [ _ ] | [] -> coord_list + | c :: _ -> c :: List.rev coord_list + else List.rev coord_list + in + Some { parts; prim = Polygon (thickness, corner_list) }) + +let parse_rect = + create_lib_parse_fun ~name:"rectangle" ~regexp_str:"S %d %d %d %d %d %d %d %s" + ~processing:(fun x1 y1 x2 y2 parts _ thickness _ -> + try + let c1 = RelCoord (x1, y1) in + let c2 = RelCoord (x2, y2) in + let rect_poly = [ c1; RelCoord (x1, y2); c2; RelCoord (x2, y1); c1 ] in + Some { parts; prim = Polygon (thickness, rect_poly) } + with _ -> None) + +let parse_circle = + create_lib_parse_fun ~name:"circle" ~regexp_str:"C %d %d %d %d %d %d" + ~processing:(fun x y radius parts _ width -> + try let center = RelCoord (x, y) in - let sp = RelCoord (spx, spy) in - let ep = RelCoord (epx, epy) in - let s = Size sz in - Some {parts; prim= Arc {sp; ep; s; radius; center}} ) - - let parse_line line = - if String.length line > 0 then ( - match line.[0] with - | 'A' -> ( + Some { parts; prim = Circle (width, { center; radius }) } + with _ -> None) + +let parse_pin = + create_lib_parse_fun ~name:"pin" + ~regexp_str:"X %s %s %d %d %d %[RLUD] %d %d %d %d %s %s" + ~processing:(fun nm nb x y sz o nm_sz nb_sz parts _ _ c -> + if String.length c = 0 || c.[0] != 'N' then + try + let contact = RelCoord (x, y) in + let length = Size sz in + let orient = pin_orientation_of_string o in + let name = (nm, Size nm_sz) in + let number = (nb, Size nb_sz) in + Some { parts; prim = Pin { name; number; length; contact; orient } } + with _ -> None + else Some { parts = -1; prim = Field }) + +let parse_alias = + create_lib_parse_fun ~name:"ALIAS" ~regexp_str:"ALIAS %s@@" + ~processing:(fun sp -> + Some (parse_list ~cond:(fun s -> String.length s > 0) " %s " sp)) + +let parse_text = + create_lib_parse_fun ~name:"Text" ~regexp_str:"T %d %d %d %d %d %d %d %s" + ~processing:(fun _ x y sz _ parts _ text -> + let c = RelCoord (x, y) in + let s = Size sz in + Some { parts; prim = Text { c; text; s } }) + +let parse_arc = + create_lib_parse_fun ~name:"Arc" + ~regexp_str:"A %d %d %d %d %d %d %d %d %s %d %d %d %d" + ~processing:(fun x y radius _ _ parts _ sz _ spx spy epx epy -> + let center = RelCoord (x, y) in + let sp = RelCoord (spx, spy) in + let ep = RelCoord (epx, epy) in + let s = Size sz in + Some { parts; prim = Arc { sp; ep; s; radius; center } }) + +let parse_line line = + if String.length line > 0 then ( + match line.[0] with + | 'A' -> ( match parse_arc line with - | Some a -> - a - | None -> - failwith ("Error parsing arc " ^ line) ) - | 'P' -> ( + | Some a -> a + | None -> failwith ("Error parsing arc " ^ line)) + | 'P' -> ( match parse_Poly line with - | Some p -> - p - | None -> - failwith ("Error parsing poly " ^ line) ) - | 'S' -> ( + | Some p -> p + | None -> failwith ("Error parsing poly " ^ line)) + | 'S' -> ( match parse_rect line with - | Some p -> - p - | None -> - failwith ("Error parsing rectangle " ^ line) ) - | 'C' -> ( + | Some p -> p + | None -> failwith ("Error parsing rectangle " ^ line)) + | 'C' -> ( match parse_circle line with - | Some c -> - c - | None -> - failwith ("Error parsing circle " ^ line) ) - | 'F' -> - {parts= -1; prim= Field} - | 'X' -> ( + | Some c -> c + | None -> failwith ("Error parsing circle " ^ line)) + | 'F' -> { parts = -1; prim = Field } + | 'X' -> ( match parse_pin line with - | Some p -> - p - | None -> - failwith ("Error parsing pin :" ^ line) ) - | 'T' -> ( + | Some p -> p + | None -> failwith ("Error parsing pin :" ^ line)) + | 'T' -> ( match parse_text line with - | Some t -> - t - | None -> - failwith ("Error parsing pin :" ^ line) ) - | ' ' | '$' -> - {parts= -1; prim= Field} - | _ -> - Printf.printf "throwing away line '%s'\n" line ; - {parts= -1; prim= Field} ) - else {parts= -1; prim= Field} - - let append_lib line (lib, comp_option, acc) = - match comp_option with - | None -> - if - String.length line > 3 - && String.compare (String.sub line 0 3) "DEF" = 0 - then - match parse_def line with - | Some (name, draw_pnum, draw_pname, multi) -> - let new_comp = - {names= [name]; draw_pnum; draw_pname; multi; graph= []} - in - (lib, Some new_comp, []) - | None -> - failwith ("could not parse component definition " ^ line) - else (lib, None, []) - | Some comp -> - if String.compare line "DRAW" = 0 || String.compare line "ENDDRAW" = 0 - then (lib, comp_option, acc) - else if String.compare line "ENDDEF" = 0 then ( - let comp = {comp with graph= List.rev acc} in - ((add_component comp lib), None, []) ) - else if - String.length line > 6 - && String.compare (String.sub line 0 5) "ALIAS" = 0 - then - match parse_alias line with - | None -> - failwith (Printf.sprintf "ALIAS line %s parse error\n" line) - | Some name_list -> - ( lib - , Some {comp with names= List.rev_append comp.names name_list} - , acc ) - else - let prim = parse_line line in - (lib, comp_option, prim :: acc) + | Some t -> t + | None -> failwith ("Error parsing pin :" ^ line)) + | ' ' | '$' -> { parts = -1; prim = Field } + | _ -> + Printf.printf "throwing away line '%s'\n" line; + { parts = -1; prim = Field }) + else { parts = -1; prim = Field } + +let append_lib line (lib, comp_option, acc) = + match comp_option with + | None -> + if + String.length line > 3 && String.compare (String.sub line 0 3) "DEF" = 0 + then + match parse_def line with + | Some (name, draw_pnum, draw_pname, multi) -> + let new_comp = + { names = [ name ]; draw_pnum; draw_pname; multi; graph = [] } + in + (lib, Some new_comp, []) + | None -> failwith ("could not parse component definition " ^ line) + else (lib, None, []) + | Some comp -> + if String.compare line "DRAW" = 0 || String.compare line "ENDDRAW" = 0 + then (lib, comp_option, acc) + else if String.compare line "ENDDEF" = 0 then + let comp = { comp with graph = List.rev acc } in + (add_component comp lib, None, []) + else if + String.length line > 6 + && String.compare (String.sub line 0 5) "ALIAS" = 0 + then + match parse_alias line with + | None -> failwith (Printf.sprintf "ALIAS line %s parse error\n" line) + | Some name_list -> + ( lib, + Some { comp with names = List.rev_append comp.names name_list }, + acc ) + else + let prim = parse_line line in + (lib, comp_option, prim :: acc) diff --git a/kicadsch/src/kicadLib_sigs.ml b/kicadsch/src/kicadLib_sigs.ml index 29cb385..de20a8e 100644 --- a/kicadsch/src/kicadLib_sigs.ml +++ b/kicadsch/src/kicadLib_sigs.ml @@ -1,31 +1,34 @@ open KicadDefs type relcoord = RelCoord of int * int - -type circle = {center: relcoord; radius: int} - -type ellipse = {center: relcoord; major_radius: int; minor_radius: int; rotation_angle: int} - -type ellipse_arc = - { center: relcoord - ; major_radius: int - ; minor_radius: int - ; rotation_angle: int - ; start_angle: int - ; end_angle: int - } +type circle = { center : relcoord; radius : int } + +type ellipse = { + center : relcoord; + major_radius : int; + minor_radius : int; + rotation_angle : int; +} + +type ellipse_arc = { + center : relcoord; + major_radius : int; + minor_radius : int; + rotation_angle : int; + start_angle : int; + end_angle : int; +} type pin_orientation = P_L | P_R | P_U | P_D [@@deriving show] - type pin_tag = string * size -type pin = - { name: pin_tag - ; number: pin_tag - ; length: size - ; contact: relcoord - ; orient: pin_orientation - } +type pin = { + name : pin_tag; + number : pin_tag; + length : size; + contact : relcoord; + orient : pin_orientation; +} type primitive = | Field @@ -34,44 +37,42 @@ type primitive = | Ellipse of int * ellipse | EllipseArc of int * ellipse_arc | Pin of pin - | Text of {c: relcoord; text: string; s: size} - | Arc of - { s: size - ; radius: int - ; sp: relcoord - ; ep: relcoord - ; center: relcoord - } + | Text of { c : relcoord; text : string; s : size } + | Arc of { + s : size; + radius : int; + sp : relcoord; + ep : relcoord; + center : relcoord; + } | Bezier of int * relcoord list -type elt = { parts: int - ; prim: primitive - } +type elt = { parts : int; prim : primitive } -type component = - { names: string list - ; draw_pnum: bool - ; draw_pname: bool - ; multi: bool - ; graph: elt list - } +type component = { + names : string list; + draw_pnum : bool; + draw_pname : bool; + multi : bool; + graph : elt list; +} module Lib : Hashtbl.S with type key := string = Hashtbl.Make (struct - type t = string + type t = string - let equal = String.equal + let equal = String.equal + let get_i s n = int_of_char s.[n] - let get_i s n = int_of_char s.[n] - - let hash s = - let rec build_hash h i = - if i < 0 then h else build_hash ((h * 47) + get_i s i) (i - 1) - in - build_hash 0 (String.length s - 1) - end) + let hash s = + let rec build_hash h i = + if i < 0 then h else build_hash ((h * 47) + get_i s i) (i - 1) + in + build_hash 0 (String.length s - 1) +end) type library = component Lib.t -let lib (): library = Lib.create 256 + +let lib () : library = Lib.create 256 let fix_illegal_chars name = String.map (function '/' | ':' -> '_' | c -> c) name @@ -79,9 +80,7 @@ let fix_illegal_chars name = let add_component comp lib = List.iter (fun name -> Lib.replace lib (fix_illegal_chars name) comp) - comp.names ; + comp.names; lib - -let get_comp lib comp_name = - Lib.find_opt lib (fix_illegal_chars comp_name) +let get_comp lib comp_name = Lib.find_opt lib (fix_illegal_chars comp_name) diff --git a/kicadsch/src/kicadSchV5.ml b/kicadsch/src/kicadSchV5.ml index d7c03f2..8a201b1 100644 --- a/kicadsch/src/kicadSchV5.ml +++ b/kicadsch/src/kicadSchV5.ml @@ -1,4 +1,4 @@ -module Defs = KicadDefs +module Defs = KicadDefs open Defs module Sigs = KicadSch_sigs module Sexp = SexpKicadSch @@ -14,8 +14,7 @@ module MakeSchPainter (P : Painter) : let file_extension = ".sch" - type rect = {c: coord; dim: coord} - + type rect = { c : coord; dim : coord } type linetype = Wire | Bus | Line | WireEntry | BusEntry type component = @@ -23,11 +22,12 @@ module MakeSchPainter (P : Painter) : | Unique of single_reference | Multiple of multi_reference list - type componentContext = - { component: component - ; sym: string option - ; origin: coord option - ; fields: field list } + type componentContext = { + component : component; + sym : string option; + origin : coord option; + fields : field list; + } type schParseContext = | BodyContext @@ -38,73 +38,57 @@ module MakeSchPainter (P : Painter) : | TextContext of label option | BitmapContext of bitmapContext - type schContext = + type schContext = { + lib : KicadLibParserV1.t; + c : schParseContext; + canevas : EltPainter.t; + rev : revision; + allow_missing_component : bool; + } + + let initial_context ?(allow_missing_component = false) rev = { - lib: KicadLibParserV1.t - ; c: schParseContext - ; canevas: EltPainter.t - ; rev: revision - ; allow_missing_component: bool + lib = KicadLibParserV1.lib (); + c = BodyContext; + canevas = EltPainter.create (P.get_context ()); + rev; + allow_missing_component; } - let initial_context ?allow_missing_component:(allow_missing_component=false) rev = - {lib=KicadLibParserV1.lib (); c=BodyContext; canevas=EltPainter.create (P.get_context ()); rev; allow_missing_component} - - let porttype_of_string = function - | "U" | "UnSpc" -> - UnSpcPort - | "T" | "3State" -> - ThreeStatePort - | "O" | "Output" -> - OutputPort - | "I" | "Input" -> - InputPort - | "B" | "BiDi" -> - BiDiPort - | "~" -> - NoPort + | "U" | "UnSpc" -> UnSpcPort + | "T" | "3State" -> ThreeStatePort + | "O" | "Output" -> OutputPort + | "I" | "Input" -> InputPort + | "B" | "BiDi" -> BiDiPort + | "~" -> NoPort | _ as s -> - ignore (Printf.printf "unknown port type %s\n" s) ; + ignore (Printf.printf "unknown port type %s\n" s); NoPort let justify_of_string s = match s.[0] with - | 'L' | '0' -> - J_left - | 'R' | '2' -> - J_right - | 'C' -> - J_center - | 'B' | '1' -> - J_bottom - | 'T' | '3' -> - J_top - | c -> - failwith (Printf.sprintf "no match for justify! (%c)" c) + | 'L' | '0' -> J_left + | 'R' | '2' -> J_right + | 'C' -> J_center + | 'B' | '1' -> J_bottom + | 'T' | '3' -> J_top + | c -> failwith (Printf.sprintf "no match for justify! (%c)" c) let style_of_string s = let i = (fst s).[0] and b = (snd s).[0] in match (i, b) with - | 'N', 'B' -> - Bold - | 'I', 'N' -> - Italic - | 'I', 'B' -> - BoldItalic - | 'N', 'N' -> - NoStyle - | _ -> - failwith (Printf.sprintf "no match for style! (%c %c)" i b) + | 'N', 'B' -> Bold + | 'I', 'N' -> Italic + | 'I', 'B' -> BoldItalic + | 'N', 'N' -> NoStyle + | _ -> failwith (Printf.sprintf "no match for style! (%c %c)" i b) let orientation_of_string s = match s.[0] with - | 'H' -> - Orient_H - | 'V' -> - Orient_V - | c -> - failwith (Printf.sprintf "no match for orientation! (%c)" c) + | 'H' -> Orient_H + | 'V' -> Orient_V + | c -> failwith (Printf.sprintf "no match for orientation! (%c)" c) (* Parsing a sch file *) open Schparse @@ -120,7 +104,7 @@ module MakeSchPainter (P : Painter) : and stl = style_of_string (String.sub vjustbi 1 1, String.sub vjustbi 2 1) and visible = flags.[3] = '0' && not (String.equal "~" name) in - Some (nb, visible, name, o, co, s, j, stl) ) + Some (nb, visible, name, o, co, s, j, stl)) let parse_L = create_parse_fun ~name:"Component L" ~regexp_str:"L %s %s" @@ -141,174 +125,157 @@ module MakeSchPainter (P : Painter) : let the_part = int_of_string @@ String.sub part_s 6 (String.length part_s - 7) in - Some (the_ref, the_part) ) + Some (the_ref, the_part)) let parse_transfo = let check x = x = 1 || x = 0 || x = -1 in - create_parse_fun ~name:"Component transformation" - ~regexp_str:" %d %d %d %s" ~extract_fun:(fun a b c ds -> + create_parse_fun ~name:"Component transformation" ~regexp_str:" %d %d %d %s" + ~extract_fun:(fun a b c ds -> if String.length ds > 0 then let d = int_of_string ds in - if check a && check b && check c && check d then - Some (a, b, c, Some d) + if check a && check b && check c && check d then Some (a, b, c, Some d) else ( - Printf.printf "Bad transfo matrix! %d %d %d %d\n" a b c d ; - None ) - else Some (a, b, c, None) ) + Printf.printf "Bad transfo matrix! %d %d %d %d\n" a b c d; + None) + else Some (a, b, c, None)) let swap_justify = function - | J_left -> - J_right - | J_center -> - J_center - | J_right -> - J_left - | J_bottom -> - J_top - | J_top -> - J_bottom - - let parse_component_line lib (line : string) (comp : componentContext) allow_missing - canevas : componentContext * EltPainter.t = + | J_left -> J_right + | J_center -> J_center + | J_right -> J_left + | J_bottom -> J_top + | J_top -> J_bottom + + let parse_component_line lib (line : string) (comp : componentContext) + allow_missing canevas : componentContext * EltPainter.t = let update_comp comp = (comp, canevas) in - if String.length line == 0 then - comp, canevas + if String.length line == 0 then (comp, canevas) else - let first = line.[0] in - match first with - | 'A' -> - update_comp - @@ parse_AR line - ~onerror:(fun () -> comp) - ~process:(fun (the_ref, the_unit) -> - if the_ref.[String.length the_ref - 1] = '?' then comp - else - let new_name = {m_piece= the_ref; m_unitnr= the_unit} in + let first = line.[0] in + match first with + | 'A' -> + update_comp + @@ parse_AR line + ~onerror:(fun () -> comp) + ~process:(fun (the_ref, the_unit) -> + if the_ref.[String.length the_ref - 1] = '?' then comp + else + let new_name = { m_piece = the_ref; m_unitnr = the_unit } in + let component = + Multiple + (match comp.component with + | NoComp | Unique _ -> [ new_name ] + | Multiple l -> new_name :: l) + in + { comp with component }) + | 'F' -> + update_comp + @@ parse_F line + ~onerror:(fun () -> comp) + ~process:(fun (nb, visible, text, o, co, s, j, stl) -> + if visible && String.length text > 0 then + { + comp with + fields = { nb; text; o; co; s; j; stl } :: comp.fields; + } + else comp) + | 'U' -> + update_comp + @@ parse_U line + ~onerror:(fun () -> comp) + ~process:(fun (u, _, _) -> let component = - Multiple - ( match comp.component with - | NoComp | Unique _ -> - [new_name] - | Multiple l -> - new_name :: l ) + match comp.component with + | NoComp -> Unique { piece = None; unitnr = Some u } + | Unique r -> Unique { r with unitnr = Some u } + | Multiple _ -> comp.component in - {comp with component} ) - | 'F' -> - update_comp - @@ parse_F line - ~onerror:(fun () -> comp) - ~process:(fun (nb, visible, text, o, co, s, j, stl) -> - if visible && String.length text > 0 then - {comp with fields= {nb; text; o; co; s; j; stl} :: comp.fields} - else comp ) - | 'U' -> - update_comp - @@ parse_U line - ~onerror:(fun () -> comp) - ~process:(fun (u, _, _) -> - let component = - match comp.component with - | NoComp -> - Unique {piece= None; unitnr= Some u} - | Unique r -> - Unique {r with unitnr= Some u} - | Multiple _ -> - comp.component - in - {comp with component} ) - | 'P' -> - update_comp - @@ parse_P line - ~onerror:(fun () -> comp) - ~process:(fun c -> {comp with origin= Some c}) - | 'L' -> - update_comp - @@ parse_L line - ~onerror:(fun () -> comp) - ~process:(fun (sym_s, n) -> - let component = - match comp.component with - | NoComp -> - Unique {piece= Some n; unitnr= None} - | Unique r -> - Unique {r with piece= Some n} - | Multiple _ -> - comp.component - in - let sym = Some sym_s in - {comp with component; sym} ) - | ' ' -> - parse_transfo line - ~onerror:(fun () -> (comp, canevas)) - ~process:(fun (a, b, c, d_opt) -> - match d_opt with - | Some d -> ( - let {component; origin; fields; sym} = comp in - match (origin, sym) with - | Some origin, Some sym -> ( - let res = - match component with - | Unique {unitnr= Some m_unitnr; piece= Some m_piece} -> - Some ([{m_unitnr; m_piece}], m_unitnr) - | Multiple m -> ( - match m with - | [] -> + { comp with component }) + | 'P' -> + update_comp + @@ parse_P line + ~onerror:(fun () -> comp) + ~process:(fun c -> { comp with origin = Some c }) + | 'L' -> + update_comp + @@ parse_L line + ~onerror:(fun () -> comp) + ~process:(fun (sym_s, n) -> + let component = + match comp.component with + | NoComp -> Unique { piece = Some n; unitnr = None } + | Unique r -> Unique { r with piece = Some n } + | Multiple _ -> comp.component + in + let sym = Some sym_s in + { comp with component; sym }) + | ' ' -> + parse_transfo line + ~onerror:(fun () -> (comp, canevas)) + ~process:(fun (a, b, c, d_opt) -> + match d_opt with + | Some d -> ( + let { component; origin; fields; sym } = comp in + match (origin, sym) with + | Some origin, Some sym -> ( + let res = + match component with + | Unique + { unitnr = Some m_unitnr; piece = Some m_piece } -> + Some ([ { m_unitnr; m_piece } ], m_unitnr) + | Multiple m -> ( + match m with + | [] -> None + | c :: _ -> Some (m, c.m_unitnr)) + | Unique { unitnr = None; _ } + | Unique { piece = None; _ } + | NoComp -> None - | c :: _ -> - Some (m, c.m_unitnr) ) - | Unique {unitnr= None; _} - | Unique {piece= None; _} - | NoComp -> - None - in - match res with - | None -> - Printf.printf - "cannot plot component with missing definitions !" ; - (comp, canevas) - | Some (refs, m_unitnr) -> - let transfo = ((a, b), (c, d)) in - let canevas', is_multi = - EltPainter.modify_canevas - (CPainter.plot_comp (KicadLibParserV1.get_comp_lib lib) sym m_unitnr origin transfo allow_missing) - canevas - in - let draw = EltPainter.draw_field origin transfo is_multi refs in - (comp, List.fold_left draw canevas' fields) ) - | _ -> - Printf.printf - "cannot plot component with missing definitions !" ; - (comp, canevas) ) - | None -> - (comp, canevas) ) - | _ -> - ignore (Printf.printf "ignored %s\n" line) ; - (comp, canevas) + in + match res with + | None -> + Printf.printf + "cannot plot component with missing definitions !"; + (comp, canevas) + | Some (refs, m_unitnr) -> + let transfo = ((a, b), (c, d)) in + let canevas', is_multi = + EltPainter.modify_canevas + (CPainter.plot_comp + (KicadLibParserV1.get_comp_lib lib) + sym m_unitnr origin transfo allow_missing) + canevas + in + let draw = + EltPainter.draw_field origin transfo is_multi refs + in + (comp, List.fold_left draw canevas' fields)) + | _ -> + Printf.printf + "cannot plot component with missing definitions !"; + (comp, canevas)) + | None -> (comp, canevas)) + | _ -> + ignore (Printf.printf "ignored %s\n" line); + (comp, canevas) let parse_wire_wire = create_parse_fun ~name:"Wire header" ~regexp_str:"%s %s %s" ~extract_fun:(fun kind width line -> match (kind, width, line) with - | "Wire", "Wire", "Line" -> - Some Wire - | "Wire", "Bus", "Line" -> - Some Bus - | "Wire", "Notes", "Line" -> - Some Line - | "Wire", "Wire", "Note" -> - Some Line - | "Entry", "Wire", "Line" -> - Some WireEntry - | "Entry", "Bus", "Line" -> - Some BusEntry - | _, _, _ -> - None ) + | "Wire", "Wire", "Line" -> Some Wire + | "Wire", "Bus", "Line" -> Some Bus + | "Wire", "Notes", "Line" -> Some Line + | "Wire", "Wire", "Note" -> Some Line + | "Entry", "Wire", "Line" -> Some WireEntry + | "Entry", "Bus", "Line" -> Some BusEntry + | _, _, _ -> None) let parse_wire_line = create_parse_fun ~name:"Wire" ~regexp_str:" %d %d %d %d" ~extract_fun:(fun x1 y1 x2 y2 -> let c1 = Coord (x1, y1) and c2 = Coord (x2, y2) in - Some (c1, c2) ) + Some (c1, c2)) let parse_noconn_line = create_parse_fun ~name:"NoConn" ~regexp_str:"NoConn ~ %d %d" @@ -322,7 +289,7 @@ module MakeSchPainter (P : Painter) : create_parse_fun ~name:"Sheet Field 0 or 1" ~regexp_str:"F%[01] %S %d" ~extract_fun:(fun num name size -> let number = int_of_string num in - Some (number, name, Size size) ) + Some (number, name, Size size)) let parse_sheet_other_fields = create_parse_fun ~name:"Sheet generic field" @@ -332,7 +299,7 @@ module MakeSchPainter (P : Painter) : let justif = justify_of_string j in let c = Coord (x, y) in let s = Size sz in - Some (name, ptype, justif, c, s) ) + Some (name, ptype, justif, c, s)) let parse_sheet_field = create_parse_fun ~name:"detect sheet field" ~regexp_str:"F%d" @@ -342,7 +309,7 @@ module MakeSchPainter (P : Painter) : create_parse_fun ~name:"Sheet Rect" ~regexp_str:"S %d %d %d %d" ~extract_fun:(fun x1 y1 x2 y2 -> let c = Coord (x1, y1) and dim = Coord (x2, y2) in - Some {c; dim} ) + Some { c; dim }) let parse_text_line = create_parse_fun ~name:"Text header" ~regexp_str:"Text %s %d %d %s %d %s" @@ -354,15 +321,12 @@ module MakeSchPainter (P : Painter) : (PortLabel (Glabel, porttype_of_string lorient), swap_justify j) | "HLabel" -> (PortLabel (Hlabel, porttype_of_string lorient), swap_justify j) - | "Label" -> - (TextLabel WireLabel, j) - | "Notes" -> - (TextLabel TextNote, j) - | _ -> - (TextLabel TextNote, j) + | "Label" -> (TextLabel WireLabel, j) + | "Notes" -> (TextLabel TextNote, j) + | _ -> (TextLabel TextNote, j) in - let result : label option = Some {size; orient; labeltype; c} in - result ) + let result : label option = Some { size; orient; labeltype; c } in + result) let parse_descr_header = create_parse_fun ~name:"Descr header" ~regexp_str:"$Descr %s %d %d" @@ -374,7 +338,7 @@ module MakeSchPainter (P : Painter) : if value.[0] = '"' then let new_val = String.sub value 1 (String.length value - 2) in Some (field, new_val) - else Some (field, value) ) + else Some (field, value)) let parse_bm_pos = create_parse_fun ~name:"Bitmap Pos" ~regexp_str:"Pos %d %d" @@ -384,14 +348,13 @@ module MakeSchPainter (P : Painter) : create_parse_fun ~name:"Bitmap Scale" ~regexp_str:"Scale %f" ~extract_fun:(fun sc -> Some sc) - (* high level parsing *) - let parse_sheet_line line context canevas : rect option*EltPainter.t = + let parse_sheet_line line context canevas : rect option * EltPainter.t = match line.[0] with | 'F' -> - ( context - , parse_sheet_field line + ( context, + parse_sheet_field line ~onerror:(fun () -> canevas) ~process:(fun number -> if number < 2 then @@ -399,24 +362,22 @@ module MakeSchPainter (P : Painter) : ~onerror:(fun () -> canevas) ~process:(fun (number, name, s) -> match context with - | Some {c; dim} -> + | Some { c; dim } -> EltPainter.draw_sheet_field name number s c dim canevas - | None -> - canevas ) + | None -> canevas) else parse_sheet_other_fields line ~onerror:(fun () -> canevas) ~process:(fun (name, ptype, justif, c, s) -> - EltPainter.draw_port name ptype justif c s canevas ) ) ) + EltPainter.draw_port name ptype justif c s canevas)) ) | 'S' -> parse_sheet_rect line ~onerror:(fun () -> (context, canevas)) - ~process:(fun ({c; dim} as range) -> - (Some range, EltPainter.draw_sheet_rect c dim canevas) ) - | 'U' -> - (context, canevas) + ~process:(fun ({ c; dim } as range) -> + (Some range, EltPainter.draw_sheet_rect c dim canevas)) + | 'U' -> (context, canevas) | _ -> - Printf.printf "unknown sheet line (%s)" line ; + Printf.printf "unknown sheet line (%s)" line; (context, canevas) let starts_with str p = @@ -432,133 +393,171 @@ module MakeSchPainter (P : Painter) : let parse_body_line ctx line = if String.compare line "$Comp" = 0 then - {ctx with c=ComponentContext - {component= NoComp; sym= None; origin= None; fields= []}} - + { + ctx with + c = + ComponentContext + { component = NoComp; sym = None; origin = None; fields = [] }; + } else if String.compare line "$Bitmap" = 0 then - {ctx with c=BitmapContext {pos= None; scale= None; data= None}} + { ctx with c = BitmapContext { pos = None; scale = None; data = None } } else if starts_with line "$Descr" then parse_descr_header line - ~onerror:(fun () -> {ctx with c=BodyContext}) + ~onerror:(fun () -> { ctx with c = BodyContext }) ~process:(fun (_, (Coord (x, y) as f_left)) -> - {ctx with c=DescrContext (Coord (x - 4000, y - 100)) - ;canevas=EltPainter.draw_page_frame f_left ctx.canevas } ) + { + ctx with + c = DescrContext (Coord (x - 4000, y - 100)); + canevas = EltPainter.draw_page_frame f_left ctx.canevas; + }) else if starts_with line "Wire" || starts_with line "Entry" then - ( parse_wire_wire line - ~onerror:(fun () -> {ctx with c=BodyContext}) - ~process:(fun lt -> {ctx with c=WireContext lt})) + parse_wire_wire line + ~onerror:(fun () -> { ctx with c = BodyContext }) + ~process:(fun lt -> { ctx with c = WireContext lt }) else if starts_with line "NoConn" then - {ctx with c=BodyContext - ; canevas=(parse_noconn_line line - ~onerror:(fun () -> ctx.canevas) - ~process:(fun c -> EltPainter.draw_no_connect c ctx.canevas))} + { + ctx with + c = BodyContext; + canevas = + parse_noconn_line line + ~onerror:(fun () -> ctx.canevas) + ~process:(fun c -> EltPainter.draw_no_connect c ctx.canevas); + } else if starts_with line "Connection" then parse_conn_line line - ~onerror:(fun () -> ctx) - ~process:(fun conn_c -> - {ctx with c=BodyContext - ; canevas=EltPainter.draw_junction conn_c ctx.canevas}) - else if String.compare line "$Sheet" = 0 then {ctx with c=SheetContext None} + ~onerror:(fun () -> ctx) + ~process:(fun conn_c -> + { + ctx with + c = BodyContext; + canevas = EltPainter.draw_junction conn_c ctx.canevas; + }) + else if String.compare line "$Sheet" = 0 then + { ctx with c = SheetContext None } else if starts_with line "Text" then let lab : label option = parse_text_line line ~onerror:(fun () -> None) ~process:(fun l -> Some l) in - {ctx with c=TextContext lab} - else {ctx with c=BodyContext} + { ctx with c = TextContext lab } + else { ctx with c = BodyContext } let parse_descr_line line c canevas = parse_descr_body line ~onerror:(fun () -> canevas) - ~process:(fun (field, content) -> EltPainter.draw_title_field c field content canevas) + ~process:(fun (field, content) -> + EltPainter.draw_title_field c field content canevas) let append_bm_line data_opt line = match data_opt with - | None -> - failwith "not adding data to None image" + | None -> failwith "not adding data to None image" | Some buf -> parse_list " %x " line |> List.rev_map char_of_int |> List.iter (Buffer.add_char buf) let parse_bitmap_line line b = if starts_with line "Pos" then - { b with - pos= + { + b with + pos = parse_bm_pos line ~onerror:(fun () -> b.pos) - ~process:(fun c -> Some c) } + ~process:(fun c -> Some c); + } else if starts_with line "Scale" then - { b with - scale= + { + b with + scale = parse_bm_scale line ~onerror:(fun () -> b.scale) - ~process:(fun s -> Some s) } + ~process:(fun s -> Some s); + } else if starts_with line "Data" then - {b with data= Some (Buffer.create 1000)} - else ( append_bm_line b.data line ; b ) + { b with data = Some (Buffer.create 1000) } + else ( + append_bm_line b.data line; + b) - let write_revision c ctx = - EltPainter.write_revision c ctx.rev ctx.canevas + let write_revision c ctx = EltPainter.write_revision c ctx.rev ctx.canevas let parse_line line ctx = match ctx.c with | DescrContext page_size as c -> - if String.compare line "$EndDescr" = 0 then - let canevas = write_revision page_size ctx in - {ctx with c=BodyContext; canevas} - else {ctx with c;canevas=(parse_descr_line line page_size ctx.canevas)} + if String.compare line "$EndDescr" = 0 then + let canevas = write_revision page_size ctx in + { ctx with c = BodyContext; canevas } + else + { ctx with c; canevas = parse_descr_line line page_size ctx.canevas } | ComponentContext comp -> - if String.compare line "$EndComp" = 0 then {ctx with c=BodyContext} + if String.compare line "$EndComp" = 0 then { ctx with c = BodyContext } else - let comp, canevas = parse_component_line ctx.lib line comp ctx.allow_missing_component ctx.canevas in - {ctx with c=ComponentContext comp; canevas} - | BodyContext -> - parse_body_line ctx line + let comp, canevas = + parse_component_line ctx.lib line comp ctx.allow_missing_component + ctx.canevas + in + { ctx with c = ComponentContext comp; canevas } + | BodyContext -> parse_body_line ctx line | WireContext l -> - parse_wire_line line - ~onerror:(fun () -> {ctx with c=BodyContext}) - ~process:(fun (start, stop) -> - let canevas = - match l with - | Bus -> EltPainter.draw_bus [start; stop] false ctx.canevas - | BusEntry -> EltPainter.draw_bus [start; stop] true ctx.canevas - | Wire -> EltPainter.draw_wire [start; stop] false ctx.canevas - | WireEntry -> EltPainter.draw_wire [start; stop] true ctx.canevas - | Line -> EltPainter.draw_line [start; stop] ctx.canevas - in {ctx with c=BodyContext;canevas}) + parse_wire_line line + ~onerror:(fun () -> { ctx with c = BodyContext }) + ~process:(fun (start, stop) -> + let canevas = + match l with + | Bus -> EltPainter.draw_bus [ start; stop ] false ctx.canevas + | BusEntry -> EltPainter.draw_bus [ start; stop ] true ctx.canevas + | Wire -> EltPainter.draw_wire [ start; stop ] false ctx.canevas + | WireEntry -> + EltPainter.draw_wire [ start; stop ] true ctx.canevas + | Line -> EltPainter.draw_line [ start; stop ] ctx.canevas + in + { ctx with c = BodyContext; canevas }) | SheetContext sc -> - if String.compare line "$EndSheet" = 0 then {ctx with c=BodyContext} + if String.compare line "$EndSheet" = 0 then { ctx with c = BodyContext } else let nsc, canevas = parse_sheet_line line sc ctx.canevas in - {ctx with c=SheetContext nsc; canevas} + { ctx with c = SheetContext nsc; canevas } | TextContext sc -> ( - match sc with - | None -> - failwith "TextContext without definition!" - | Some v -> - {ctx with c=BodyContext; canevas=EltPainter.draw_text_line line v ctx.canevas} ) + match sc with + | None -> failwith "TextContext without definition!" + | Some v -> + { + ctx with + c = BodyContext; + canevas = EltPainter.draw_text_line line v ctx.canevas; + }) | BitmapContext b -> if String.compare line "$EndBitmap" = 0 then - {ctx with c=BodyContext; canevas=EltPainter.draw_bitmap b ctx.canevas} + { + ctx with + c = BodyContext; + canevas = EltPainter.draw_bitmap b ctx.canevas; + } else let nb = parse_bitmap_line line b in - {ctx with c=BitmapContext nb} + { ctx with c = BitmapContext nb } - let output_context (ctx: schContext) : painterContext = EltPainter.get_context ctx.canevas + let output_context (ctx : schContext) : painterContext = + EltPainter.get_context ctx.canevas - let trim_cr l = if String.ends_with ~suffix:"\r" l then String.sub l 0 (String.length l - 1) else l + let trim_cr l = + if String.ends_with ~suffix:"\r" l then String.sub l 0 (String.length l - 1) + else l let add_lib content ctxt = - let lines = String.split_on_char '\n' content in - let lib = List.fold_left (fun c l -> KicadLibParserV1.append_lib (trim_cr l) c) ctxt.lib lines in - {ctxt with lib} + let lines = String.split_on_char '\n' content in + let lib = + List.fold_left + (fun c l -> KicadLibParserV1.append_lib (trim_cr l) c) + ctxt.lib lines + in + { ctxt with lib } let parse_sheet initctx content = let parse c l = let trimmed_line = trim_cr l in - parse_line trimmed_line c in + parse_line trimmed_line c + in let lines = String.split_on_char '\n' content in List.fold_left parse initctx lines - end diff --git a/kicadsch/src/kicadSchV5.mli b/kicadsch/src/kicadSchV5.mli index cb971f4..408f5cf 100644 --- a/kicadsch/src/kicadSchV5.mli +++ b/kicadsch/src/kicadSchV5.mli @@ -1,3 +1,4 @@ open KicadSch_sigs -module MakeSchPainter: functor (P: Painter) -> SchPainter with type painterContext := P.t +module MakeSchPainter : functor (P : Painter) -> + SchPainter with type painterContext := P.t diff --git a/kicadsch/src/kicadSchV6.ml b/kicadsch/src/kicadSchV6.ml deleted file mode 100644 index 0ff185d..0000000 --- a/kicadsch/src/kicadSchV6.ml +++ /dev/null @@ -1,140 +0,0 @@ -module Sigs = KicadSch_sigs -open Sigs -open KicadLib_sigs -module Decode = Sexp_decode.Make(Base.Sexp) -open Decode -open! StdLabels -open SexpKicadSch - -module MakeSchPainter (P : Painter) : - SchPainter with type painterContext := P.t = struct - module CPainter = Kicadlib.MakePainter (P) - module EltPainter = SchElementPainter.MakePainter (P) - - type schContext = - { - lib: library - ; canevas: EltPainter.t - ; rev: revision - ; allow_missing_component: bool - ; base_coord: coord - } - - type painterContext = P.t - - let file_extension = ".kicad_sch" - ;; - - let initial_context ?allow_missing_component:(allow_missing_component=false) rev = - {lib=lib();canevas=EltPainter.create (P.get_context ()); rev; allow_missing_component; base_coord=Coord (0, 0)} - - let orient_of_rot = fun rot j -> - match rot, j with - | 0, J_left -> J_left - | 0, J_right -> J_right - | 90, _ -> J_top - | 180, J_left -> J_right - | 180, J_right -> J_right - | 270, _ -> J_bottom - | s, _ -> failwith ("unknown angle " ^ string_of_int s) - - - let parse_schematics initctx (content_tree, pos) = - let sch_expr = - field "kicad_sch" - (fields - ~default:initctx - [ - ("version", int >>| fun _ args -> args) - ; ("generator", string ~escaped:false >>| fun _ args -> args) - ; ("generator_version", string ~escaped:false >>| fun _ args -> args) - ; ("paper", paper_size_args >>| fun base_coord args -> {args with canevas=EltPainter.draw_page_frame base_coord args.canevas; base_coord}) - ; ("title_block", title_block_args >>| fun (title, date, rev, company, comments) args -> - let Coord (x, y) = args.base_coord in - let corner = Coord (x - 4000, y) in - let canevas = args.canevas |> - EltPainter.draw_title_field corner "Title" title |> - EltPainter.draw_title_field corner "Date" date |> - EltPainter.draw_title_field corner "Rev" rev |> - EltPainter.draw_title_field corner "Comp" company in - let canevas = List.fold_left ~init:canevas ~f:(fun cv (c, text) -> - EltPainter.draw_title_field corner ("Comment" ^ (string_of_int c)) text cv) comments in - {args with canevas}) - ; ("uuid", uuid_args >>| fun _ args -> args) - ; ("lib_symbols", lib_symbols_args >>| (fun s args -> - {args with lib=List.fold_left ~init:args.lib ~f:(fun alib comp -> KicadLib_sigs.add_component comp alib) s})) - ; ("junction", junction_args >>| (fun c args -> {args with canevas=EltPainter.draw_junction c args.canevas})) - ; ("no_connect", no_connect_args >>| (fun c args -> {args with canevas=EltPainter.draw_no_connect c args.canevas})) - ; ("wire", bus_wire_args >>| (fun l args -> {args with canevas=EltPainter.draw_wire l false args.canevas})) - ; ("bus", bus_wire_args >>| (fun l args -> {args with canevas=EltPainter.draw_bus l false args.canevas})) - ; ("rectangle", rectangle_args >>| (fun (s, e) args -> {args with canevas=EltPainter.draw_sheet_rect s e args.canevas})) - ; ("text", text_gen_args >>| (fun (c, text, size, rot, j) args -> - let orient = orient_of_rot rot j in - let l={c; size; orient;labeltype=TextLabel TextNote} in - {args with canevas=EltPainter.draw_text_line text l args.canevas})) - ; ("bus_entry", bus_entry_args >>| - (fun ((Coord (xs, ys) as c), (xe, ye)) args -> - let end_point = Coord (xs+xe, ys+ye) in - {args with canevas=EltPainter.draw_wire [c; end_point] true args.canevas})) - ; ("label", label_args >>| (fun (c, rot, text, size, orient) args -> - let orient = orient_of_rot rot orient in - let label = {c; size; orient;labeltype=TextLabel WireLabel} in - {args with canevas=EltPainter.draw_label text label args.canevas})) - ; ("hierarchical_label", hierarchical_label_args >>| (fun (c, rot, text, size, shape, orient) args -> - let orient = orient_of_rot rot orient in - let label = {c; size; orient; labeltype=PortLabel (Hlabel, shape)} in - {args with canevas=EltPainter.draw_label text label args.canevas})) - ; ("global_label", hierarchical_label_args >>| (fun (c, rot, text, size, shape, orient) args -> - let orient = orient_of_rot rot orient in - let label = {c; size; orient; labeltype=PortLabel (Glabel, shape)} in - {args with canevas=EltPainter.draw_label text label args.canevas})) - ; ("polyline", polyline_args >>| (fun (_s, l) args -> {args with canevas=EltPainter.draw_line l args.canevas})) - ; ("image", image_args >>| (fun b args -> - {args with canevas=EltPainter.draw_bitmap b args.canevas})) - ; ("symbol", sch_symbol_args >>| (fun sym args -> - let ((a11,a12),(a21,a22)) = - match sym.rot with - | 0 -> ((1, 0), (0, -1)) - | 90 -> ((0, -1), (-1, 0)) - | 180 -> ((-1, 0), (0, 1)) - | 270 -> ((0, 1), (1, 0)) - | s -> (* Aucune chance de marcher : on utilise des int et on calcule des cos et des sin ! *) - let angle_rad = float_of_int s /. 180. *. Float.pi in - let cos_val = int_of_float (cos angle_rad) in - let sin_val = int_of_float (sin angle_rad) in - ((cos_val, sin_val), (-sin_val, cos_val)) in - let invert_x = if sym.mirror_x then -1 else 1 in - let invert_y = if sym.mirror_y then -1 else 1 in - let transfo = ((invert_y * a11, invert_y * a12), (invert_x * a21, invert_x * a22)) in - let cpaint = CPainter.plot_comp args.lib sym.lib_id sym.unit_nr sym.pos transfo args.allow_missing_component in - let new_canevas, is_multi = EltPainter.modify_canevas cpaint args.canevas in - let canevas = List.fold_left ~f:(fun canevas prop -> match (field_build prop) with None -> canevas | Some field -> EltPainter.draw_field prop.at transfo is_multi [] canevas field) ~init:new_canevas sym.properties in - {args with canevas})) - ; ("sheet", sheet_args >>| ( fun (at, size, properties, hierachical_pins) args -> - let cnv = EltPainter.draw_sheet_rect at size args.canevas in - let cnv1 = List.fold_left ~init: cnv ~f:(fun cv {value; id; at; effects; _} -> EltPainter.draw_sheet_field value id (Size (Option.fold ~none:10 ~some:fontsize_of_effect effects)) at size cv) properties in - let canevas = List.fold_left ~init:cnv1 ~f:(fun cv (name, port_type, justif, pos, s) -> EltPainter.draw_port name port_type justif pos s cv) hierachical_pins in - {args with canevas})) - ; ("sheet_instances", repeat1_full_list sheet_path_instance_expr >>| (fun _ args -> args)) - ; ("bus_alias", string ~escaped:true <*> skip >>| (fun _ args -> args)) - ] - ) - in - match Decode.run_with_result sch_expr content_tree with - | Ok res -> res - | Error sub -> - (match Parsexp.Positions.find_sub_sexp_phys pos content_tree ~sub:sub with - | Some err_range -> failwith (Format.sprintf "%d:%d: Decode failed for %s@." err_range.start_pos.line err_range.start_pos.col (Sexplib0.Sexp.to_string sub)) - | None -> failwith "decode failed!") - - let add_lib _content ctxt = ctxt - - let parse_sheet initctx content = - let tree_opt = Parsexp.Single_and_positions.parse_string content in - match tree_opt with - | Ok tree -> parse_schematics initctx tree - | Error _error -> failwith ("content is not correct sexp: ") (* TODO *) - - let output_context (ctx: schContext): painterContext = EltPainter.get_context ctx.canevas - -end diff --git a/kicadsch/src/kicadSchV6.mli b/kicadsch/src/kicadSchV6.mli deleted file mode 100644 index cb971f4..0000000 --- a/kicadsch/src/kicadSchV6.mli +++ /dev/null @@ -1,3 +0,0 @@ -open KicadSch_sigs - -module MakeSchPainter: functor (P: Painter) -> SchPainter with type painterContext := P.t diff --git a/kicadsch/src/kicadSchV8.ml b/kicadsch/src/kicadSchV8.ml index 2fb5102..a0328e3 100644 --- a/kicadsch/src/kicadSchV8.ml +++ b/kicadsch/src/kicadSchV8.ml @@ -2,7 +2,7 @@ module Sigs = KicadSch_sigs open Sigs open KicadLib_sigs open KicadDefs -module Decode = Sexp_decode.Make(Base.Sexp) +module Decode = Sexp_decode.Make (Base.Sexp) open Decode open! StdLabels open SexpKicadSch @@ -12,25 +12,30 @@ module MakeSchPainter (P : Painter) : module CPainter = Kicadlib.MakePainter (P) module EltPainter = SchElementPainter.MakePainter (P) - type schContext = - { - lib: library - ; canevas: EltPainter.t - ; rev: revision - ; allow_missing_component: bool - ; base_coord: coord - } + type schContext = { + lib : library; + canevas : EltPainter.t; + rev : revision; + allow_missing_component : bool; + base_coord : coord; + } type painterContext = P.t let file_extension = ".kicad_sch" - ;; - let initial_context ?allow_missing_component:(allow_missing_component=false) rev = - {lib=lib();canevas=EltPainter.create (P.get_context ()); rev; allow_missing_component; base_coord=Coord (0, 0)} + let initial_context ?(allow_missing_component = false) rev = + { + lib = lib (); + canevas = EltPainter.create (P.get_context ()); + rev; + allow_missing_component; + base_coord = Coord (0, 0); + } - let orient_of_rot = fun rot j -> - match rot, j with + let orient_of_rot = + fun rot j -> + match (rot, j) with | 0, J_left -> J_left | 0, _ -> J_right | 90, _ -> J_top @@ -39,140 +44,304 @@ module MakeSchPainter (P : Painter) : | 270, _ -> J_bottom | s, _ -> failwith ("unknown angle " ^ string_of_int s) - let parse_schematics initctx (content_tree, pos) = let sch_expr = field "kicad_sch" - (fields - ~default:initctx + (fields ~default:initctx [ - ("version", int >>| fun _ args -> args) - ; ("generator", string ~escaped:false >>| fun _ args -> args) - ; ("generator_version", string ~escaped:false >>| fun _ args -> args) - ; ("paper", paper_size_args >>| fun base_coord args -> {args with canevas=EltPainter.draw_page_frame base_coord args.canevas; base_coord}) - ; ("title_block", title_block_v8_args >>| fun (title, date, rev, company, comments) args -> - let Coord (x, y) = args.base_coord in - let corner = Coord (x - 4000, y) in - let canevas = args.canevas |> - EltPainter.draw_title_field corner "Title" title |> - EltPainter.draw_title_field corner "Date" date |> - EltPainter.draw_title_field corner "Rev" rev |> - EltPainter.draw_title_field corner "Comp" company in - let canevas = List.fold_left ~init:canevas ~f:(fun cv (c, text) -> - EltPainter.draw_title_field corner ("Comment" ^ (string_of_int c)) text cv) comments in - {args with canevas}) - ; ("uuid", uuid_args >>| fun _ args -> args) - ; ("lib_symbols", lib_symbols_args >>| (fun s args -> - {args with lib=List.fold_left ~init:args.lib ~f:(fun alib comp -> KicadLib_sigs.add_component comp alib) s})) - ; ("junction", junction_args >>| (fun c args -> {args with canevas=EltPainter.draw_junction c args.canevas})) - ; ("no_connect", no_connect_args >>| (fun c args -> {args with canevas=EltPainter.draw_no_connect c args.canevas})) - ; ("wire", bus_wire_args >>| (fun l args -> {args with canevas=EltPainter.draw_wire l false args.canevas})) - ; ("bus", bus_wire_args >>| (fun l args -> {args with canevas=EltPainter.draw_bus l false args.canevas})) - ; ("rectangle", rectangle_args >>| (fun (s, e) args -> {args with canevas=EltPainter.draw_sheet_rect s e args.canevas})) - ; ("text", text_gen_args >>| (fun (c, text, size, rot, j) args -> + ("version", int >>| fun _ args -> args); + ("generator", string ~escaped:false >>| fun _ args -> args); + ("generator_version", string ~escaped:false >>| fun _ args -> args); + ( "paper", + paper_size_args >>| fun base_coord args -> + { + args with + canevas = EltPainter.draw_page_frame base_coord args.canevas; + base_coord; + } ); + ( "title_block", + title_block_v8_args + >>| fun (title, date, rev, company, comments) args -> + let (Coord (x, y)) = args.base_coord in + let corner = Coord (x - 4000, y) in + let canevas = + args.canevas + |> EltPainter.draw_title_field corner "Title" title + |> EltPainter.draw_title_field corner "Date" date + |> EltPainter.draw_title_field corner "Rev" rev + |> EltPainter.draw_title_field corner "Comp" company + in + let canevas = + List.fold_left ~init:canevas + ~f:(fun cv (c, text) -> + EltPainter.draw_title_field corner + ("Comment" ^ string_of_int c) + text cv) + comments + in + { args with canevas } ); + ("uuid", uuid_args >>| fun _ args -> args); + ( "lib_symbols", + lib_symbols_args >>| fun s args -> + { + args with + lib = + List.fold_left ~init:args.lib + ~f:(fun alib comp -> KicadLib_sigs.add_component comp alib) + s; + } ); + ( "junction", + junction_args >>| fun c args -> + { args with canevas = EltPainter.draw_junction c args.canevas } + ); + ( "no_connect", + no_connect_args >>| fun c args -> + { args with canevas = EltPainter.draw_no_connect c args.canevas } + ); + ( "wire", + bus_wire_args >>| fun l args -> + { args with canevas = EltPainter.draw_wire l false args.canevas } + ); + ( "bus", + bus_wire_args >>| fun l args -> + { args with canevas = EltPainter.draw_bus l false args.canevas } + ); + ( "rectangle", + rectangle_args >>| fun (s, e) args -> + { + args with + canevas = EltPainter.draw_sheet_rect s e args.canevas; + } ); + ( "text", + text_gen_args >>| fun (c, text, size, rot, j) args -> let orient = orient_of_rot rot j in - let l={c; size; orient;labeltype=TextLabel TextNote} in - {args with canevas=EltPainter.draw_text_line text l args.canevas})) - ; ("bus_entry", bus_entry_args >>| - (fun ((Coord (xs, ys) as c), (xe, ye)) args -> - let end_point = Coord (xs+xe, ys+ye) in - {args with canevas=EltPainter.draw_wire [c; end_point] true args.canevas})) - ; ("label", label_args >>| (fun (c, rot, text, size, orient) args -> + let l = { c; size; orient; labeltype = TextLabel TextNote } in + { + args with + canevas = EltPainter.draw_text_line text l args.canevas; + } ); + ( "bus_entry", + bus_entry_args >>| fun ((Coord (xs, ys) as c), (xe, ye)) args -> + let end_point = Coord (xs + xe, ys + ye) in + { + args with + canevas = + EltPainter.draw_wire [ c; end_point ] true args.canevas; + } ); + ( "label", + label_args >>| fun (c, rot, text, size, orient) args -> let orient = orient_of_rot rot orient in - let label = {c; size; orient;labeltype=TextLabel WireLabel} in - {args with canevas=EltPainter.draw_label text label args.canevas})) - ; ("hierarchical_label", hierarchical_label_args >>| (fun (c, rot, text, size, shape, orient) args -> + let label = + { c; size; orient; labeltype = TextLabel WireLabel } + in + { + args with + canevas = EltPainter.draw_label text label args.canevas; + } ); + ( "hierarchical_label", + hierarchical_label_args + >>| fun (c, rot, text, size, shape, orient) args -> let orient = orient_of_rot rot orient in - let label = {c; size; orient; labeltype=PortLabel (Hlabel, shape)} in - {args with canevas=EltPainter.draw_label text label args.canevas})) - ; ("global_label", hierarchical_label_args >>| (fun (c, rot, text, size, shape, orient) args -> + let label = + { c; size; orient; labeltype = PortLabel (Hlabel, shape) } + in + { + args with + canevas = EltPainter.draw_label text label args.canevas; + } ); + ( "global_label", + hierarchical_label_args + >>| fun (c, rot, text, size, shape, orient) args -> let orient = orient_of_rot rot orient in - let label = {c; size; orient; labeltype=PortLabel (Glabel, shape)} in - {args with canevas=EltPainter.draw_label text label args.canevas})) - ; ("directive_label", label_args >>| (fun (c, rot, text, size, orient) args -> + let label = + { c; size; orient; labeltype = PortLabel (Glabel, shape) } + in + { + args with + canevas = EltPainter.draw_label text label args.canevas; + } ); + ( "directive_label", + label_args >>| fun (c, rot, text, size, orient) args -> let orient = orient_of_rot rot orient in - let label = {c; size; orient; labeltype=TextLabel WireLabel} in - {args with canevas=EltPainter.draw_label text label args.canevas})) - ; ("netclass_flag", label_args >>| (fun (c, rot, text, size, orient) args -> + let label = + { c; size; orient; labeltype = TextLabel WireLabel } + in + { + args with + canevas = EltPainter.draw_label text label args.canevas; + } ); + ( "netclass_flag", + label_args >>| fun (c, rot, text, size, orient) args -> let orient = orient_of_rot rot orient in - let label = {c; size; orient; labeltype=TextLabel WireLabel} in - {args with canevas=EltPainter.draw_label text label args.canevas})) - ; ("polyline", polyline_args >>| (fun (_s, l) args -> {args with canevas=EltPainter.draw_line l args.canevas})) - ; ("image", image_args >>| (fun b args -> - {args with canevas=EltPainter.draw_bitmap b args.canevas})) - ; ("symbol", sch_symbol_args >>| (fun sym args -> - let ((a11,a12),(a21,a22)) = + let label = + { c; size; orient; labeltype = TextLabel WireLabel } + in + { + args with + canevas = EltPainter.draw_label text label args.canevas; + } ); + ( "polyline", + polyline_args >>| fun (_s, l) args -> + { args with canevas = EltPainter.draw_line l args.canevas } ); + ( "image", + image_args >>| fun b args -> + { args with canevas = EltPainter.draw_bitmap b args.canevas } ); + ( "symbol", + sch_symbol_args >>| fun sym args -> + let (a11, a12), (a21, a22) = match sym.rot with | 0 -> ((1, 0), (0, -1)) | 90 -> ((0, -1), (-1, 0)) | 180 -> ((-1, 0), (0, 1)) | 270 -> ((0, 1), (1, 0)) | s -> - let angle_rad = float_of_int s /. 180. *. Float.pi in - let cos_val = int_of_float (cos angle_rad) in - let sin_val = int_of_float (sin angle_rad) in - ((cos_val, sin_val), (-sin_val, cos_val)) in + let angle_rad = float_of_int s /. 180. *. Float.pi in + let cos_val = int_of_float (cos angle_rad) in + let sin_val = int_of_float (sin angle_rad) in + ((cos_val, sin_val), (-sin_val, cos_val)) + in let invert_x = if sym.mirror_x then -1 else 1 in let invert_y = if sym.mirror_y then -1 else 1 in - let transfo = ((invert_y * a11, invert_y * a12), (invert_x * a21, invert_x * a22)) in - let lookup_key = Option.value sym.lib_name ~default:sym.lib_id in - let cpaint = CPainter.plot_comp args.lib lookup_key sym.unit_nr sym.pos transfo args.allow_missing_component in - let new_canevas, is_multi = EltPainter.modify_canevas cpaint args.canevas in - let canevas = List.fold_left ~f:(fun canevas prop -> match (field_build prop) with None -> canevas | Some field -> EltPainter.draw_field prop.at transfo is_multi [] canevas field) ~init:new_canevas sym.properties in - {args with canevas})) - ; ("sheet", sheet_args_v8 >>| (fun (at, size, properties, hierachical_pins) args -> + let transfo = + ( (invert_y * a11, invert_y * a12), + (invert_x * a21, invert_x * a22) ) + in + let lookup_key = Option.value sym.lib_name ~default:sym.lib_id in + let cpaint = + CPainter.plot_comp args.lib lookup_key sym.unit_nr sym.pos + transfo args.allow_missing_component + in + let new_canevas, is_multi = + EltPainter.modify_canevas cpaint args.canevas + in + let canevas = + List.fold_left + ~f:(fun canevas prop -> + match field_build prop with + | None -> canevas + | Some field -> + EltPainter.draw_field prop.at transfo is_multi [] + canevas field) + ~init:new_canevas sym.properties + in + { args with canevas } ); + ( "sheet", + sheet_args_v8 + >>| fun (at, size, properties, hierachical_pins) args -> let cnv = EltPainter.draw_sheet_rect at size args.canevas in - let cnv1 = List.fold_left ~init: cnv ~f:(fun cv {value; id; at; effects; _} -> EltPainter.draw_sheet_field value id (Size (Option.fold ~none:10 ~some:fontsize_of_effect effects)) at size cv) properties in - let canevas = List.fold_left ~init:cnv1 ~f:(fun cv (name, port_type, justif, pos, s) -> EltPainter.draw_port name port_type justif pos s cv) hierachical_pins in - {args with canevas})) - (* V8-only top-level items *) - ; ("arc", sch_arc_args >>| (fun arc_opt args -> + let cnv1 = + List.fold_left ~init:cnv + ~f:(fun cv { value; id; at; effects; _ } -> + EltPainter.draw_sheet_field value id + (Size + (Option.fold ~none:10 ~some:fontsize_of_effect effects)) + at size cv) + properties + in + let canevas = + List.fold_left ~init:cnv1 + ~f:(fun cv (name, port_type, justif, pos, s) -> + EltPainter.draw_port name port_type justif pos s cv) + hierachical_pins + in + { args with canevas } ) + (* V8-only top-level items *); + ( "arc", + sch_arc_args >>| fun arc_opt args -> match arc_opt with | None -> args | Some (center, start_pt, end_pt, radius) -> - {args with canevas=EltPainter.draw_arc center start_pt end_pt radius args.canevas})) - ; ("circle", sch_circle_args >>| (fun (center, radius) args -> - {args with canevas=EltPainter.draw_circle center radius args.canevas})) - ; ("bezier", sch_bezier_args >>| (fun pts args -> + { + args with + canevas = + EltPainter.draw_arc center start_pt end_pt radius + args.canevas; + } ); + ( "circle", + sch_circle_args >>| fun (center, radius) args -> + { + args with + canevas = EltPainter.draw_circle center radius args.canevas; + } ); + ( "bezier", + sch_bezier_args >>| fun pts args -> match pts with - | _::_::_ -> {args with canevas=EltPainter.draw_line pts args.canevas} - | _ -> args)) - ; ("rule_area", sch_rule_area_args >>| (fun pts args -> + | _ :: _ :: _ -> + { args with canevas = EltPainter.draw_line pts args.canevas } + | _ -> args ); + ( "rule_area", + sch_rule_area_args >>| fun pts args -> match pts with - | _::_::_ -> {args with canevas=EltPainter.draw_line pts args.canevas} - | _ -> args)) - ; ("text_box", sch_text_box_args >>| (fun (corner, dim, text, effects) args -> - let Coord (x, y) = corner and Coord (w, h) = dim in - let cnv = EltPainter.draw_sheet_rect corner (Coord (x + w, y + h)) args.canevas in - let sz = match effects with + | _ :: _ :: _ -> + { args with canevas = EltPainter.draw_line pts args.canevas } + | _ -> args ); + ( "text_box", + sch_text_box_args >>| fun (corner, dim, text, effects) args -> + let (Coord (x, y)) = corner and (Coord (w, h)) = dim in + let cnv = + EltPainter.draw_sheet_rect corner + (Coord (x + w, y + h)) + args.canevas + in + let sz = + match effects with | None -> Size 100 - | Some e -> let Coord (_, sy) = e.font.size in Size sy in - let orient = match effects with + | Some e -> + let (Coord (_, sy)) = e.font.size in + Size sy + in + let orient = + match effects with | None -> J_left - | Some e -> justify_of_effect e in - let label = {c=corner; size=sz; orient; labeltype=TextLabel TextNote} in - {args with canevas=EltPainter.draw_text_line text label cnv})) - ; ("ellipse", sch_ellipse_args >>| fun (center, ma, mi, rot) args -> - {args with canevas=EltPainter.draw_ellipse center ma mi rot args.canevas}) - ; ("ellipse_arc", sch_ellipse_arc_args >>| fun (center, ma, mi, rot, sa, ea) args -> - {args with canevas=EltPainter.draw_ellipse_arc center ma mi rot sa ea args.canevas}) - ; ("table", skip_all >>| fun _ args -> args) - ; ("net_chain", skip_all >>| fun _ args -> args) - ; ("group", skip_all >>| fun _ args -> args) - ; ("embedded_fonts", skip_all >>| fun _ args -> args) - ; ("embedded_files", skip_all >>| fun _ args -> args) - ; ("sheet_instances", repeat1_full_list sheet_path_instance_expr >>| (fun _ args -> args)) - ; ("symbol_instances", skip_all >>| fun _ args -> args) - ; ("bus_alias", string ~escaped:true <*> skip >>| (fun _ args -> args)) - ] - ) + | Some e -> justify_of_effect e + in + let label = + { + c = corner; + size = sz; + orient; + labeltype = TextLabel TextNote; + } + in + { args with canevas = EltPainter.draw_text_line text label cnv } + ); + ( "ellipse", + sch_ellipse_args >>| fun (center, ma, mi, rot) args -> + { + args with + canevas = EltPainter.draw_ellipse center ma mi rot args.canevas; + } ); + ( "ellipse_arc", + sch_ellipse_arc_args + >>| fun (center, ma, mi, rot, sa, ea) args -> + { + args with + canevas = + EltPainter.draw_ellipse_arc center ma mi rot sa ea + args.canevas; + } ); + ("table", skip_all >>| fun _ args -> args); + ("net_chain", skip_all >>| fun _ args -> args); + ("group", skip_all >>| fun _ args -> args); + ("embedded_fonts", skip_all >>| fun _ args -> args); + ("embedded_files", skip_all >>| fun _ args -> args); + ( "sheet_instances", + repeat1_full_list sheet_path_instance_expr >>| fun _ args -> args + ); + ("symbol_instances", skip_all >>| fun _ args -> args); + ("bus_alias", string ~escaped:true <*> skip >>| fun _ args -> args); + ]) in match Decode.run_with_result sch_expr content_tree with | Ok res -> res - | Error sub -> - (match Parsexp.Positions.find_sub_sexp_phys pos content_tree ~sub:sub with - | Some err_range -> failwith (Format.sprintf "%d:%d: Decode failed for %s@." err_range.start_pos.line err_range.start_pos.col (Sexplib0.Sexp.to_string sub)) - | None -> failwith "decode failed!") + | Error sub -> ( + match Parsexp.Positions.find_sub_sexp_phys pos content_tree ~sub with + | Some err_range -> + failwith + (Format.sprintf "%d:%d: Decode failed for %s@." + err_range.start_pos.line err_range.start_pos.col + (Sexplib0.Sexp.to_string sub)) + | None -> failwith "decode failed!") let add_lib _content ctxt = ctxt @@ -180,8 +349,8 @@ module MakeSchPainter (P : Painter) : let tree_opt = Parsexp.Single_and_positions.parse_string content in match tree_opt with | Ok tree -> parse_schematics initctx tree - | Error _error -> failwith ("content is not correct sexp: ") - - let output_context (ctx: schContext): painterContext = EltPainter.get_context ctx.canevas + | Error _error -> failwith "content is not correct sexp: " + let output_context (ctx : schContext) : painterContext = + EltPainter.get_context ctx.canevas end diff --git a/kicadsch/src/kicadSchV8.mli b/kicadsch/src/kicadSchV8.mli index cb971f4..408f5cf 100644 --- a/kicadsch/src/kicadSchV8.mli +++ b/kicadsch/src/kicadSchV8.mli @@ -1,3 +1,4 @@ open KicadSch_sigs -module MakeSchPainter: functor (P: Painter) -> SchPainter with type painterContext := P.t +module MakeSchPainter : functor (P : Painter) -> + SchPainter with type painterContext := P.t diff --git a/kicadsch/src/kicadSch_sigs.mli b/kicadsch/src/kicadSch_sigs.mli index 68e78c3..1b07167 100644 --- a/kicadsch/src/kicadSch_sigs.mli +++ b/kicadsch/src/kicadSch_sigs.mli @@ -1,5 +1,4 @@ -(** - Kicad modules Signatures *) +(** Kicad modules Signatures *) open KicadDefs @@ -15,18 +14,14 @@ type justify = J_left | J_right | J_center | J_bottom | J_top (** *) (** Style of a text *) type style = Bold | Italic | BoldItalic | NoStyle (** *) +type kolor = [ `NoColor | `Black | `Green | `Red | `Blue | `Brown ] (** Color of the text. These are the colors appearing in Kicad schematics *) -type kolor = [`NoColor | `Black | `Green | `Red | `Blue | `Brown] -(** Transformation matrix of a relative coordinate around an absolute coordinate. - The matrix is layed out as a pair of lines of pairs *) type transfo = (int * int) * (int * int) +(** Transformation matrix of a relative coordinate around an absolute + coordinate. The matrix is layed out as a pair of lines of pairs *) -type revision = - | First of string - | Second of string - | No_Rev - +type revision = First of string | Second of string | No_Rev type portrange = Glabel | Hlabel type porttype = @@ -38,79 +33,87 @@ type porttype = | BiDiPort type labeluse = WireLabel | TextNote - type labeltype = PortLabel of portrange * porttype | TextLabel of labeluse - -type label = {c: coord; size: size; orient: justify; labeltype: labeltype} - -type field = - { nb: int - ; text: string - ; o: orientation - ; co: coord - ; s: size - ; j: justify - ; stl: style } - -type single_reference = {piece: string option; unitnr: int option} - -type multi_reference = {m_piece: string; m_unitnr: int} - -type bitmapContext = - {pos: coord option; scale: float option; data: Buffer.t option} +type label = { c : coord; size : size; orient : justify; labeltype : labeltype } + +type field = { + nb : int; + text : string; + o : orientation; + co : coord; + s : size; + j : justify; + stl : style; +} + +type single_reference = { piece : string option; unitnr : int option } +type multi_reference = { m_piece : string; m_unitnr : int } + +type bitmapContext = { + pos : coord option; + scale : float option; + data : Buffer.t option; +} module type Painter = sig - (** A module able to paint a canvas with several graphic primitives - and then to process the canvas into a picture file format. The - functions are supposed to be pure *) + (** A module able to paint a canvas with several graphic primitives and then + to process the canvas into a picture file format. The functions are + supposed to be pure *) - (** the canvas of the painter *) type t + (** the canvas of the painter *) val paint_text : - ?kolor:kolor - -> String.t - -> orientation - -> coord - -> size - -> justify - -> style - -> t - -> t - (** [paint ?kolor text orient coord size justification style canvas] - adds a [text] with the given [orient], [size], [justification] - and [style] at the given [coord] to [canvas]. *) + ?kolor:kolor -> + String.t -> + orientation -> + coord -> + size -> + justify -> + style -> + t -> + t + (** [paint ?kolor text orient coord size justification style canvas] adds a + [text] with the given [orient], [size], [justification] and [style] at the + given [coord] to [canvas]. *) val paint_line : ?kolor:kolor -> ?width:size -> coord -> coord -> t -> t - (** [paint_line ?kolor width start end canvas] paints a line with - the given [kolor] and [width] between [start] and [stop] on - [canvas]. *) + (** [paint_line ?kolor width start end canvas] paints a line with the given + [kolor] and [width] between [start] and [stop] on [canvas]. *) val paint_circle : ?kolor:kolor -> ?fill:kolor -> coord -> int -> t -> t - (** [paint_circle ?kolor center radius canvas] paints a circle - filled with the given [kolor] defined by [center] and [radius] on - [canvas]. *) + (** [paint_circle ?kolor center radius canvas] paints a circle filled with the + given [kolor] defined by [center] and [radius] on [canvas]. *) val paint_rect : ?kolor:kolor -> ?fill:kolor -> coord -> coord -> t -> t - (** [paint_rect ?kolor corner1 corner2 canvas] paints a rectangle - filled with the given [kolor] defined by [corner1] and [corner2] - on [canvas]. *) + (** [paint_rect ?kolor corner1 corner2 canvas] paints a rectangle filled with + the given [kolor] defined by [corner1] and [corner2] on [canvas]. *) val paint_image : coord -> float -> Buffer.t -> t -> t - (** [paint_image corner scale png canvas] paints a [png] image - filled at [corner], scaled at [scale] on [canvas]. *) + (** [paint_image corner scale png canvas] paints a [png] image filled at + [corner], scaled at [scale] on [canvas]. *) - val paint_ellipse : ?kolor:kolor -> ?fill:kolor -> coord -> int -> int -> int -> t -> t + val paint_ellipse : + ?kolor:kolor -> ?fill:kolor -> coord -> int -> int -> int -> t -> t (** [paint_ellipse center major_radius minor_radius rotation_angle canvas] paints an ellipse with the given [kolor] and [fill] defined by [center], [major_radius], [minor_radius], and [rotation_angle] on [canvas]. *) val paint_ellipse_arc : - ?kolor:kolor -> ?fill:kolor -> coord -> int -> int -> int -> int -> int -> t -> t + ?kolor:kolor -> + ?fill:kolor -> + coord -> + int -> + int -> + int -> + int -> + int -> + t -> + t (** [paint_ellipse_arc center major_radius minor_radius rotation_angle - start_angle end_angle canvas] paints an elliptical arc filled with - [kolor] defined by [center], radii, [rotation_angle], [start_angle] - and [end_angle] on [canvas]. *) + start_angle end_angle canvas] paints an elliptical arc filled with + [kolor] defined by [center], radii, [rotation_angle], [start_angle] and + [end_angle] on [canvas]. *) val paint_arc : ?kolor:kolor -> ?fill:kolor -> coord -> coord -> coord -> int -> t -> t @@ -121,7 +124,6 @@ module type Painter = sig val set_canevas_size : int -> int -> t -> t (** [set_canevas x y canvas] set the size of the canevas *) - val get_context : unit -> t (** [get_context ()] is a new painting canvas *) end @@ -129,58 +131,63 @@ end module type SchPainter = sig (** A module able to paint a schematic file in a painter context *) - (** the schematic context *) type schContext + (** the schematic context *) - (** the underlying context *) type painterContext + (** the underlying context *) val file_extension : string - (** [file_extension] is the extension of the file format ("sch" for v5, "kicad_sch" for v6/v7*) + (** [file_extension] is the extension of the file format ("sch" for v5, + "kicad_sch" for v6/v7*) val initial_context : ?allow_missing_component:bool -> revision -> schContext - (** [initial_context allow_missing_component revision] - is an new empty context *) + (** [initial_context allow_missing_component revision] is an new empty context + *) val add_lib : string -> schContext -> schContext - (** [add_lib content context] parse the [content] provided to - libs to the [context]. + (** [add_lib content context] parse the [content] provided to libs to the + [context]. @return the updated context *) val parse_sheet : schContext -> String.t -> schContext - (** [parse_line content context] parse a [content] of schematic and - update [context]. + (** [parse_line content context] parse a [content] of schematic and update + [context]. @return the updated context *) val output_context : schContext -> painterContext - (** [output_context context output] write the [context] as a image - format to [output] *) + (** [output_context context output] write the [context] as a image format to + [output] *) end module type CompPainter = sig - (** The library that is able to read component libraries and - memorize the read components. Then when passed a drawing context - and a component to paint it can paint the component on demand to - the drawing context *) + (** The library that is able to read component libraries and memorize the read + components. Then when passed a drawing context and a component to paint it + can paint the component on demand to the drawing context *) - (** A component Library manager *) type t = KicadLib_sigs.library + (** A component Library manager *) - (** A drawing context *) type drawContext + (** A drawing context *) val plot_comp : - t -> string -> int -> coord -> transfo -> bool -> drawContext -> drawContext * bool - (** [plot_comp lib name partnumber origin transformation - allow_missing context] finds in [lib] the component with given - [name] and plot the part [partnumber] at [origin] after - [transformation] into the graphical [context] and the fact that - the component is multipart. If the component is not found, raise - an exception, unless [allow_missing] is true. *) + t -> + string -> + int -> + coord -> + transfo -> + bool -> + drawContext -> + drawContext * bool + (** [plot_comp lib name partnumber origin transformation allow_missing + context] finds in [lib] the component with given [name] and plot the part + [partnumber] at [origin] after [transformation] into the graphical + [context] and the fact that the component is multipart. If the component + is not found, raise an exception, unless [allow_missing] is true. *) end module type KicadSchHandler = sig - - module MakeSchPainter: functor (P: Painter) -> SchPainter with type painterContext := P.t - + module MakeSchPainter : functor (P : Painter) -> + SchPainter with type painterContext := P.t end diff --git a/kicadsch/src/kicadlib.ml b/kicadsch/src/kicadlib.ml index ad26e21..9b36c6d 100644 --- a/kicadsch/src/kicadlib.ml +++ b/kicadsch/src/kicadlib.ml @@ -5,7 +5,6 @@ struct open KicadLib_sigs type t = library - type drawContext = P.t let ( +$ ) (Coord (x1, y1)) (RelCoord (x2, y2)) = Coord (x1 + x2, y1 + y2) @@ -13,39 +12,34 @@ struct let ( *$ ) ((a, b), (c, d)) (RelCoord (x, y)) = RelCoord ((a * x) + (b * y), (c * x) + (d * y)) - let rotate (origin : coord) (rotation : transfo) (relpoint : relcoord) : - coord = + let rotate (origin : coord) (rotation : transfo) (relpoint : relcoord) : coord + = origin +$ (rotation *$ relpoint) let adjust_angle ((a, b), (c, d)) angle = let x_angle = atan2 (float_of_int c) (float_of_int a) in - let det = a * d - b * c in + let det = (a * d) - (b * c) in let sign = if det > 0 then 1.0 else -1.0 in - let rad = x_angle +. sign *. (float_of_int angle *. Float.pi /. 180.0) in + let rad = x_angle +. (sign *. (float_of_int angle *. Float.pi /. 180.0)) in Float.to_int (Float.round (rad *. 180.0 /. Float.pi)) let rec plot_poly rotfun thickness points ctx = match points with - | [] | [_] -> - ctx + | [] | [ _ ] -> ctx | c1 :: c2 :: tl -> let c1' = rotfun c1 in let c2' = rotfun c2 in plot_poly rotfun thickness (c2 :: tl) (P.paint_line c1' c2' ctx) - let plot_pin rotfun {name; number; length; contact; orient} c ctx = + let plot_pin rotfun { name; number; length; contact; orient } c ctx = let (RelCoord (x, y)) = contact in let (Size delta) = length in let sc = match orient with - | P_R -> - RelCoord (x + delta, y) - | P_L -> - RelCoord (x - delta, y) - | P_U -> - RelCoord (x, y + delta) - | P_D -> - RelCoord (x, y - delta) + | P_R -> RelCoord (x + delta, y) + | P_L -> RelCoord (x - delta, y) + | P_U -> RelCoord (x, y + delta) + | P_D -> RelCoord (x, y - delta) in let (Coord (nxsc, nysc) as new_sc) = rotfun sc in let (Coord (nx, ny) as new_contact) = rotfun contact in @@ -60,8 +54,7 @@ struct let pin_ctx = P.paint_line new_sc new_contact ctx in let pname_ctx = if c.draw_pname && String.compare "~" name_text <> 0 then - P.paint_text name_text new_orient new_sc name_size new_J NoStyle - pin_ctx + P.paint_text name_text new_orient new_sc name_size new_J NoStyle pin_ctx else pin_ctx in if c.draw_pnum && String.compare "~" pin_text <> 0 then @@ -69,41 +62,53 @@ struct pname_ctx else pname_ctx - let plot_elt rotfun transfo comp part ctx {parts; prim} = + let plot_elt rotfun transfo comp part ctx { parts; prim } = if parts = 0 || parts = part then match prim with - | Polygon (t, pts) -> - plot_poly rotfun t pts ctx - | Circle (_, {center; radius}) -> + | Polygon (t, pts) -> plot_poly rotfun t pts ctx + | Circle (_, { center; radius }) -> P.paint_circle (rotfun center) radius ctx - | Ellipse (_, {center; major_radius; minor_radius; rotation_angle}) -> - let new_angle = adjust_angle transfo rotation_angle in - P.paint_ellipse (rotfun center) major_radius minor_radius new_angle ctx - | EllipseArc (_, {center; major_radius; minor_radius; rotation_angle; start_angle; end_angle}) -> - let new_rot = adjust_angle transfo rotation_angle in - let new_sa = adjust_angle transfo start_angle in - let new_ea = adjust_angle transfo end_angle in - P.paint_ellipse_arc (rotfun center) major_radius minor_radius new_rot new_sa new_ea ctx - | Field -> - ctx - | Pin p -> - plot_pin rotfun p comp ctx - | Text {c; text; s} -> + | Ellipse (_, { center; major_radius; minor_radius; rotation_angle }) -> + let new_angle = adjust_angle transfo rotation_angle in + P.paint_ellipse (rotfun center) major_radius minor_radius new_angle + ctx + | EllipseArc + ( _, + { + center; + major_radius; + minor_radius; + rotation_angle; + start_angle; + end_angle; + } ) -> + let new_rot = adjust_angle transfo rotation_angle in + let new_sa = adjust_angle transfo start_angle in + let new_ea = adjust_angle transfo end_angle in + P.paint_ellipse_arc (rotfun center) major_radius minor_radius new_rot + new_sa new_ea ctx + | Field -> ctx + | Pin p -> plot_pin rotfun p comp ctx + | Text { c; text; s } -> P.paint_text text Orient_H (rotfun c) s J_left NoStyle ctx - | Arc {radius; sp; ep; center; _} -> - P.paint_arc (rotfun center) (rotfun sp) (rotfun ep) radius ctx + | Arc { radius; sp; ep; center; _ } -> + P.paint_arc (rotfun center) (rotfun sp) (rotfun ep) radius ctx (* TODO: paint Bezier *) - | Bezier(_, _) -> ctx + | Bezier (_, _) -> ctx else ctx exception Component_Not_Found of string - let plot_comp lib comp_name part rotation origin allow_missing (ctx : drawContext) - = + let plot_comp lib comp_name part rotation origin allow_missing + (ctx : drawContext) = match get_comp lib comp_name with | Some thecomp -> - let rot = rotate rotation origin in - ( List.fold_left (fun ctx elt -> plot_elt rot origin thecomp part ctx elt) ctx thecomp.graph - , thecomp.multi ) - | None -> if allow_missing then (ctx, false) else raise (Component_Not_Found comp_name) + let rot = rotate rotation origin in + ( List.fold_left + (fun ctx elt -> plot_elt rot origin thecomp part ctx elt) + ctx thecomp.graph, + thecomp.multi ) + | None -> + if allow_missing then (ctx, false) + else raise (Component_Not_Found comp_name) end diff --git a/kicadsch/src/kicadsch.ml b/kicadsch/src/kicadsch.ml index 921f674..3bd0d11 100644 --- a/kicadsch/src/kicadsch.ml +++ b/kicadsch/src/kicadsch.ml @@ -1,8 +1,6 @@ -module Defs = KicadDefs +module Defs = KicadDefs module Sigs = KicadSch_sigs module Sexp = SexpKicadSch module Lib_sigs = KicadLib_sigs - -module V6 = KicadSchV6 module V5 = KicadSchV5 module V8 = KicadSchV8 diff --git a/kicadsch/src/schElementPainter.ml b/kicadsch/src/schElementPainter.ml index 75002ed..e198c13 100644 --- a/kicadsch/src/schElementPainter.ml +++ b/kicadsch/src/schElementPainter.ml @@ -1,91 +1,86 @@ open KicadSch_sigs open KicadDefs -module type EltPainter = -sig +module type EltPainter = sig type t (** The context fo the EltPainter *) - type drawContext (** The sub-context type of the drawer *) - val create: drawContext -> t - - val draw_field : coord -> (int * int) * (int * int) -> bool -> multi_reference list -> t -> field -> t - - val draw_port: ?kolor:[> `Black ] -> string -> porttype -> justify -> coord -> size -> t -> t - - val draw_junction: coord -> t -> t - - val draw_no_connect: coord -> t -> t - - val draw_bitmap: bitmapContext -> t -> t - - val draw_wire: coord list -> bool -> t -> t - - val draw_bus: coord list -> bool -> t -> t - - val draw_line: coord list -> t -> t - - val draw_circle: coord -> int -> t -> t + val create : drawContext -> t + + val draw_field : + coord -> + (int * int) * (int * int) -> + bool -> + multi_reference list -> + t -> + field -> + t + + val draw_port : + ?kolor:[> `Black ] -> + string -> + porttype -> + justify -> + coord -> + size -> + t -> + t + + val draw_junction : coord -> t -> t + val draw_no_connect : coord -> t -> t + val draw_bitmap : bitmapContext -> t -> t + val draw_wire : coord list -> bool -> t -> t + val draw_bus : coord list -> bool -> t -> t + val draw_line : coord list -> t -> t + + val draw_circle : coord -> int -> t -> t (** [draw_circle center radius ctx] draws a circle outline *) - val draw_ellipse: coord -> int -> int -> int -> t -> t - (** [draw_ellipse center major_radius minor_radius rotation_angle ctx] - draws an ellipse *) + val draw_ellipse : coord -> int -> int -> int -> t -> t + (** [draw_ellipse center major_radius minor_radius rotation_angle ctx] draws + an ellipse *) - val draw_ellipse_arc: coord -> int -> int -> int -> int -> int -> t -> t + val draw_ellipse_arc : coord -> int -> int -> int -> int -> int -> t -> t (** [draw_ellipse_arc center major_radius minor_radius rotation_angle - start_angle end_angle ctx] draws an elliptical arc *) + start_angle end_angle ctx] draws an elliptical arc *) - val draw_arc: coord -> coord -> coord -> int -> t -> t + val draw_arc : coord -> coord -> coord -> int -> t -> t (** [draw_arc center start_pt end_pt radius ctx] draws an arc *) - val draw_title_field: coord -> string -> string -> t -> t - - val draw_text_line: string -> label -> t -> t - - val draw_sheet_field: String.t -> int -> size -> coord -> coord -> t -> t - - val draw_sheet_rect: coord -> coord -> t -> t - - val draw_label: string -> label -> t -> t - - val draw_page_frame: coord -> t -> t - - val write_revision: coord -> revision -> t -> t - - val modify_canevas: (drawContext -> drawContext*bool) -> t -> t*bool + val draw_title_field : coord -> string -> string -> t -> t + val draw_text_line : string -> label -> t -> t + val draw_sheet_field : String.t -> int -> size -> coord -> coord -> t -> t + val draw_sheet_rect : coord -> coord -> t -> t + val draw_label : string -> label -> t -> t + val draw_page_frame : coord -> t -> t + val write_revision : coord -> revision -> t -> t + val modify_canevas : (drawContext -> drawContext * bool) -> t -> t * bool val get_context : t -> drawContext (** [get_context ctx] @return the painting canvas attached to the painter [ctx] *) - end -module MakePainter(P: Painter): EltPainter with type drawContext := P.t = +module MakePainter (P : Painter) : EltPainter with type drawContext := P.t = struct - type wireDesc = - { start: coord - ; stop: coord } - + type wireDesc = { start : coord; stop : coord } type connectionDesc = coord - type wires = - { wires: wireDesc list - ; cons: connectionDesc list - ; buses: wireDesc list - } + type wires = { + wires : wireDesc list; + cons : connectionDesc list; + buses : wireDesc list; + } - type t = - { wires: wires - ; canevas: P.t - } + type t = { wires : wires; canevas : P.t } (* type drawContext = P.t *) - let create canevas = {wires={wires=[]; cons=[]; buses=[]}; canevas} + let create canevas = + { wires = { wires = []; cons = []; buses = [] }; canevas } let swap_justify = function | J_left -> J_right @@ -99,7 +94,7 @@ struct | J_top | J_bottom -> Orient_V let draw_field (Coord (x0, y0)) ((a, b), (c, d)) is_multi refs context - {nb; text; o; co; s; j; stl} = + { nb; text; o; co; s; j; stl } = let (Coord (x, y)) = co in let xrel = x - x0 and yrel = y - y0 in let x' = (a * xrel) + (b * yrel) + x0 in @@ -107,7 +102,9 @@ struct let o' = if a = 0 then (* this is a ±90° rotation matrix *) - match o with Orient_H -> Orient_V | Orient_V -> Orient_H + match o with + | Orient_H -> Orient_V + | Orient_V -> Orient_H else o in let text = @@ -115,67 +112,59 @@ struct else String.concat "/" (List.map - (fun {m_unitnr; m_piece} -> + (fun { m_unitnr; m_piece } -> if is_multi then m_piece ^ Char.escaped (char_of_int (m_unitnr + int_of_char 'A' - 1)) - else m_piece ) + else m_piece) refs) in let j' = match o' with - | Orient_H -> - if a = -1 || b = -1 then swap_justify j else j - | Orient_V -> - if c = 1 || d = -1 then swap_justify j else j + | Orient_H -> if a = -1 || b = -1 then swap_justify j else j + | Orient_V -> if c = 1 || d = -1 then swap_justify j else j in - {context with canevas=P.paint_text text o' (Coord (x', y')) s j' stl context.canevas} + { + context with + canevas = P.paint_text text o' (Coord (x', y')) s j' stl context.canevas; + } let right_arrow = "\xE2\x96\xB6" - let left_arrow = "\xE2\x97\x80" - let diamond = "\xE2\x97\x86" - let square = "\xE2\x97\xBC" let decorate_port_name name ptype justif = let port_char = match (ptype, justif) with - | UnSpcPort, _ | NoPort, _ -> - "" - | ThreeStatePort, _ | BiDiPort, _ -> - diamond + | UnSpcPort, _ | NoPort, _ -> "" + | ThreeStatePort, _ | BiDiPort, _ -> diamond | OutputPort, (J_left | J_top) | InputPort, (J_right | J_bottom) -> left_arrow | OutputPort, (J_right | J_bottom) | InputPort, (J_left | J_top) -> right_arrow - | _, J_center -> - square + | _, J_center -> square in match justif with - | J_left | J_top -> - port_char ^ name - | J_right | J_bottom -> - name ^ port_char - | J_center -> - name - - let draw_port ?(kolor = `Black) name ptype justif (Coord (x, y)) - (Size l as s) ctx = + | J_left | J_top -> port_char ^ name + | J_right | J_bottom -> name ^ port_char + | J_center -> name + + let draw_port ?(kolor = `Black) name ptype justif (Coord (x, y)) (Size l as s) + ctx = let new_port_name = decorate_port_name name ptype justif in let orient = orientation_of_justify justif in let j = justif in let _ = kolor in let c = match orient with - | Orient_H -> - Coord (x, y + (l / 4)) - | Orient_V -> - Coord (x + (l / 4), y) + | Orient_H -> Coord (x, y + (l / 4)) + | Orient_V -> Coord (x + (l / 4), y) in - {ctx with canevas= - (P.paint_text new_port_name orient c s j NoStyle ctx.canevas)} + { + ctx with + canevas = P.paint_text new_port_name orient c s j NoStyle ctx.canevas; + } let split_lines line = let len = String.length line in @@ -190,13 +179,10 @@ struct split 0 0 [] let swap_type = function - | (UnSpcPort | ThreeStatePort | NoPort | BiDiPort) as p -> - p - | OutputPort -> - InputPort - | InputPort -> - OutputPort -(* + | (UnSpcPort | ThreeStatePort | NoPort | BiDiPort) as p -> p + | OutputPort -> InputPort + | InputPort -> OutputPort + (* let print_text_line line l ctx = let c = ctx.canevas in match l.labeltype with @@ -222,92 +208,119 @@ struct let draw_junction conn_c ctx = let delta = 10 in let canevas = P.paint_circle ~fill:`Black conn_c delta ctx.canevas in - let wires = {ctx.wires with cons=conn_c::ctx.wires.cons} in - {canevas; wires} + let wires = { ctx.wires with cons = conn_c :: ctx.wires.cons } in + { canevas; wires } let draw_no_connect (Coord (x, y)) ctx = let delta = 10 in let canevas = ctx.canevas |> P.paint_line - (Coord (x - delta, y - delta)) - (Coord (x + delta, y + delta)) + (Coord (x - delta, y - delta)) + (Coord (x + delta, y + delta)) |> P.paint_line - (Coord (x - delta, y + delta)) - (Coord (x + delta, y - delta)) in - {ctx with canevas} + (Coord (x - delta, y + delta)) + (Coord (x + delta, y - delta)) + in + { ctx with canevas } let draw_bitmap b ctx = - let canevas = match (b.pos, b.scale, b.data) with - | Some p, Some s, Some d -> - P.paint_image p s d ctx.canevas - | _ -> - ctx.canevas in - {ctx with canevas} + let canevas = + match (b.pos, b.scale, b.data) with + | Some p, Some s, Some d -> P.paint_image p s d ctx.canevas + | _ -> ctx.canevas + in + { ctx with canevas } let draw_wire l isEntry ctx = if isEntry then match l with - | [start; stop] -> - { - canevas=(P.paint_line ~kolor:`Brown ~width:(Size 2) start stop ctx.canevas) - ; wires={ctx.wires with cons=start::stop::ctx.wires.cons} - } - | _ -> raise Not_found (* TODO: find better exception *) + | [ start; stop ] -> + { + canevas = + P.paint_line ~kolor:`Brown ~width:(Size 2) start stop ctx.canevas; + wires = { ctx.wires with cons = start :: stop :: ctx.wires.cons }; + } + | _ -> raise Not_found (* TODO: find better exception *) else match l with - | start::(_::_ as tail) -> - let prev = ref start in - let append_and_memo wires point = - let start = !prev in - (prev := point; {start; stop=point}::wires) in - let wires = List.fold_left append_and_memo ctx.wires.wires tail in - {ctx with wires={ctx.wires with wires}} - | _ -> raise Not_found (* TODO: find better exception *) + | start :: (_ :: _ as tail) -> + let prev = ref start in + let append_and_memo wires point = + let start = !prev in + prev := point; + { start; stop = point } :: wires + in + let wires = List.fold_left append_and_memo ctx.wires.wires tail in + { ctx with wires = { ctx.wires with wires } } + | _ -> raise Not_found (* TODO: find better exception *) let draw_bus l isEntry ctx = if isEntry then match l with - | [start; stop] -> - { - canevas=(P.paint_line ~kolor:`Blue ~width:(Size 5) start stop ctx.canevas) - ; wires={ctx.wires with cons=start::stop::ctx.wires.cons} - } - | _ -> raise Not_found (* TODO: find better exception *) + | [ start; stop ] -> + { + canevas = + P.paint_line ~kolor:`Blue ~width:(Size 5) start stop ctx.canevas; + wires = { ctx.wires with cons = start :: stop :: ctx.wires.cons }; + } + | _ -> raise Not_found (* TODO: find better exception *) else match l with - | start::(_::_ as tail) -> - let prev = ref start in - let append_and_memo buses point = - let start = !prev in - (prev := point; {start; stop=point}::buses) in - let buses = List.fold_left append_and_memo ctx.wires.buses tail in - {ctx with wires={ctx.wires with buses}} - | _ -> raise Not_found (* TODO: find better exception *) -;; - let draw_line (l: coord list) (ctx: t) = - match l with - | start::(_::_ as tail) -> - let prev = ref start in - let append_and_memo canevas point = - let start = !prev in - (prev := point; P.paint_line ~kolor:`Black ~width:(Size 2) start point canevas) in - let canevas = List.fold_left append_and_memo ctx.canevas tail in - {ctx with canevas} - | _ -> raise Not_found (* TODO: find better exception *) -;; + | start :: (_ :: _ as tail) -> + let prev = ref start in + let append_and_memo buses point = + let start = !prev in + prev := point; + { start; stop = point } :: buses + in + let buses = List.fold_left append_and_memo ctx.wires.buses tail in + { ctx with wires = { ctx.wires with buses } } + | _ -> raise Not_found (* TODO: find better exception *) + + let draw_line (l : coord list) (ctx : t) = + match l with + | start :: (_ :: _ as tail) -> + let prev = ref start in + let append_and_memo canevas point = + let start = !prev in + prev := point; + P.paint_line ~kolor:`Black ~width:(Size 2) start point canevas + in + let canevas = List.fold_left append_and_memo ctx.canevas tail in + { ctx with canevas } + | _ -> raise Not_found (* TODO: find better exception *) + let draw_circle center radius ctx = - {ctx with canevas = P.paint_circle ~kolor:`Black center radius ctx.canevas} + { + ctx with + canevas = P.paint_circle ~kolor:`Black center radius ctx.canevas; + } let draw_ellipse center major_radius minor_radius rotation_angle ctx = - {ctx with canevas = P.paint_ellipse ~kolor:`Black center major_radius minor_radius rotation_angle ctx.canevas} + { + ctx with + canevas = + P.paint_ellipse ~kolor:`Black center major_radius minor_radius + rotation_angle ctx.canevas; + } - let draw_ellipse_arc center major_radius minor_radius rotation_angle start_angle end_angle ctx = - {ctx with canevas = P.paint_ellipse_arc ~kolor:`Black center major_radius minor_radius rotation_angle start_angle end_angle ctx.canevas} + let draw_ellipse_arc center major_radius minor_radius rotation_angle + start_angle end_angle ctx = + { + ctx with + canevas = + P.paint_ellipse_arc ~kolor:`Black center major_radius minor_radius + rotation_angle start_angle end_angle ctx.canevas; + } let draw_arc center start_pt end_pt radius ctx = - {ctx with canevas = P.paint_arc ~kolor:`Black center start_pt end_pt radius ctx.canevas} -;; + { + ctx with + canevas = + P.paint_arc ~kolor:`Black center start_pt end_pt radius ctx.canevas; + } + let draw_title_field (Coord (x, y)) field content ctx = let cvs = ctx.canevas in let canevas = @@ -318,30 +331,21 @@ struct (Size s) J_left NoStyle cvs in match field with - | "Sheet" -> - title_text ("Page: " ^ content) x (y - 200) 50 - | "Title" -> - title_text ("Title: " ^ content) x (y - 50) 100 - | "Rev" -> - title_text ("Rev: " ^ content) (x + 3200) (y - 50) 100 - | "Date" -> - title_text ("Date: " ^ content) (x + 500) (y - 200) 50 - | "Comp" -> - title_text content (x + 1000) (y - 200) 50 - | "Comment1" -> - title_text content x (y - 400) 50 - | "Comment2" -> - title_text content (x + 2000) (y - 400) 50 - | "Comment3" -> - title_text content x (y - 300) 50 - | "Comment4" -> - title_text content (x + 2000) (y - 300) 50 - | _ -> - cvs + | "Sheet" -> title_text ("Page: " ^ content) x (y - 200) 50 + | "Title" -> title_text ("Title: " ^ content) x (y - 50) 100 + | "Rev" -> title_text ("Rev: " ^ content) (x + 3200) (y - 50) 100 + | "Date" -> title_text ("Date: " ^ content) (x + 500) (y - 200) 50 + | "Comp" -> title_text content (x + 1000) (y - 200) 50 + | "Comment1" -> title_text content x (y - 400) 50 + | "Comment2" -> title_text content (x + 2000) (y - 400) 50 + | "Comment3" -> title_text content x (y - 300) 50 + | "Comment4" -> title_text content (x + 2000) (y - 300) 50 + | _ -> cvs else cvs - in {ctx with canevas} + in + { ctx with canevas } - let draw_text_line line l (c: t) = + let draw_text_line line l (c : t) = match l.labeltype with | TextLabel t -> let pcolor = match t with TextNote -> `Green | WireLabel -> `Red in @@ -354,150 +358,153 @@ struct l.size l.orient NoStyle c' in let lines = List.rev (String.split_on_char '\n' line) in - let canevas = List.fold_left paint_line c.canevas (List.mapi (fun i l -> (i, l)) lines) in - {c with canevas} + let canevas = + List.fold_left paint_line c.canevas + (List.mapi (fun i l -> (i, l)) lines) + in + { c with canevas } | PortLabel (prange, ptype) -> let pcolor = match prange with Glabel -> `Green | Hlabel -> `Red in let new_type = swap_type ptype in draw_port ~kolor:pcolor line new_type l.orient l.c l.size c - module type OrderedCoord = - sig - val compare: coord -> coord -> int + module type OrderedCoord = sig + val compare : coord -> coord -> int end - module SegmentCutter(O:OrderedCoord):(sig val cut_wires: wireDesc list -> coord list -> kolor:kolor -> width:size -> P.t -> P.t end) = - struct - module SegmentSet = Set.Make(struct - type t = wireDesc - let compare {start=start1; _} {start=start2; _} = O.compare start1 start2 - end) + module SegmentCutter (O : OrderedCoord) : sig + val cut_wires : + wireDesc list -> coord list -> kolor:kolor -> width:size -> P.t -> P.t + end = struct + module SegmentSet = Set.Make (struct + type t = wireDesc + + let compare { start = start1; _ } { start = start2; _ } = + O.compare start1 start2 + end) - let point_in_segment c {start; stop} = - (O.compare start c <= 0) && (O.compare stop c >= 0) + let point_in_segment c { start; stop } = + O.compare start c <= 0 && O.compare stop c >= 0 let con_in_a_segment c set = - match SegmentSet.find_first_opt (fun {stop; _} -> (O.compare stop c > 0)) set with + match + SegmentSet.find_first_opt (fun { stop; _ } -> O.compare stop c > 0) set + with | None -> None - | Some ({start; _} as seg) -> - if O.compare start c < 0 then - Some seg - else - None - ;; + | Some ({ start; _ } as seg) -> + if O.compare start c < 0 then Some seg else None let point_in_a_segment c set = - match SegmentSet.find_first_opt (fun {stop; _} -> (O.compare stop c >= 0)) set with + match + SegmentSet.find_first_opt (fun { stop; _ } -> O.compare stop c >= 0) set + with | None -> None - | Some ({start; _} as seg) -> - if O.compare start c <= 0 then - Some seg - else - None - ;; + | Some ({ start; _ } as seg) -> + if O.compare start c <= 0 then Some seg else None let cut_wire set con = match con_in_a_segment con set with | None -> set - | Some ({start; stop} as seg) -> - set |> SegmentSet.remove seg |> SegmentSet.add {start; stop=con} |> SegmentSet.add {start=con;stop} - ;; + | Some ({ start; stop } as seg) -> + set |> SegmentSet.remove seg + |> SegmentSet.add { start; stop = con } + |> SegmentSet.add { start = con; stop } let merge_segment ~set seg = - SegmentSet.filter (fun {start=stt; _} -> not( point_in_segment stt seg)) set - |>SegmentSet.add seg - ;; - - let insert_segment set {start; stop} = - let start, stop = if O.compare start stop <= 0 then - start, stop - else - stop, start in - match (point_in_a_segment start set), (point_in_a_segment stop set) with - | None, None -> - merge_segment ~set {start; stop} - | Some ({start=stt; _}), None -> - merge_segment ~set {start=stt; stop} - | None, Some {stop=stp; _} -> - merge_segment ~set {start; stop=stp} - | Some {start=stt; _}, Some {stop=stp; _} -> - merge_segment ~set {start=stt; stop=stp} - ;; + SegmentSet.filter + (fun { start = stt; _ } -> not (point_in_segment stt seg)) + set + |> SegmentSet.add seg + + let insert_segment set { start; stop } = + let start, stop = + if O.compare start stop <= 0 then (start, stop) else (stop, start) + in + match (point_in_a_segment start set, point_in_a_segment stop set) with + | None, None -> merge_segment ~set { start; stop } + | Some { start = stt; _ }, None -> + merge_segment ~set { start = stt; stop } + | None, Some { stop = stp; _ } -> merge_segment ~set { start; stop = stp } + | Some { start = stt; _ }, Some { stop = stp; _ } -> + merge_segment ~set { start = stt; stop = stp } let cut_wires seg_list junctions ~kolor ~width canevas = let seg_set = List.fold_left insert_segment SegmentSet.empty seg_list in let split_set = List.fold_left cut_wire seg_set junctions in - SegmentSet.fold (fun {start; stop} canevas -> P.paint_line ~kolor ~width start stop canevas) split_set canevas - ;; + SegmentSet.fold + (fun { start; stop } canevas -> + P.paint_line ~kolor ~width start stop canevas) + split_set canevas end - module VerticalSet = SegmentCutter( - struct - let compare (Coord (xs0, ys0)) (Coord (xs1, ys1)) = - match Stdlib.compare xs0 xs1 with - | 0 -> Stdlib.compare ys0 ys1 - | c -> c - end) + module VerticalSet = SegmentCutter (struct + let compare (Coord (xs0, ys0)) (Coord (xs1, ys1)) = + match Stdlib.compare xs0 xs1 with 0 -> Stdlib.compare ys0 ys1 | c -> c + end) - module HorizontalSet = SegmentCutter( - struct - let compare (Coord (xs0, ys0)) (Coord (xs1, ys1)) = - match Stdlib.compare ys0 ys1 with - | 0 -> Stdlib.compare xs0 xs1 - | c -> c - end) + module HorizontalSet = SegmentCutter (struct + let compare (Coord (xs0, ys0)) (Coord (xs1, ys1)) = + match Stdlib.compare ys0 ys1 with 0 -> Stdlib.compare xs0 xs1 | c -> c + end) let cut_all_wires junctions wires ~kolor ~width canevas = - let vertical, horizontal = List.partition (fun {start=Coord (x1, _); stop=Coord (x2, _)} -> x1 == x2) wires in - VerticalSet.cut_wires vertical junctions ~kolor ~width canevas |> - HorizontalSet.cut_wires horizontal junctions ~kolor ~width + let vertical, horizontal = + List.partition + (fun { start = Coord (x1, _); stop = Coord (x2, _) } -> x1 == x2) + wires + in + VerticalSet.cut_wires vertical junctions ~kolor ~width canevas + |> HorizontalSet.cut_wires horizontal junctions ~kolor ~width - let cut_wires_and_buses {wires;buses;cons} canevas = - cut_all_wires cons wires ~kolor:`Brown ~width:(Size 2) canevas |> - cut_all_wires cons buses ~kolor:`Blue ~width:(Size 5) + let cut_wires_and_buses { wires; buses; cons } canevas = + cut_all_wires cons wires ~kolor:`Brown ~width:(Size 2) canevas + |> cut_all_wires cons buses ~kolor:`Blue ~width:(Size 5) let get_context ctx : P.t = cut_wires_and_buses ctx.wires ctx.canevas - let draw_page_frame (Coord (x, y)) ctx = let b_width = 100 in let f_width = 4000 in let bot_x = x - b_width in let bot_y = y - b_width in let frame_x = bot_x - f_width in - let canevas = ctx.canevas - |> P.set_canevas_size x y - |> P.paint_rect - (Coord (b_width, b_width)) - (Coord (x - (2 * b_width), y - (2 * b_width))) - |> P.paint_rect (Coord (frame_x, bot_y - 150)) (Coord (f_width, 150)) - |> P.paint_rect (Coord (frame_x, bot_y - 250)) (Coord (f_width, 100)) - |> P.paint_rect (Coord (frame_x, bot_y - 550)) (Coord (f_width, 400)) - in {ctx with canevas} + let canevas = + ctx.canevas |> P.set_canevas_size x y + |> P.paint_rect + (Coord (b_width, b_width)) + (Coord (x - (2 * b_width), y - (2 * b_width))) + |> P.paint_rect (Coord (frame_x, bot_y - 150)) (Coord (f_width, 150)) + |> P.paint_rect (Coord (frame_x, bot_y - 250)) (Coord (f_width, 100)) + |> P.paint_rect (Coord (frame_x, bot_y - 550)) (Coord (f_width, 400)) + in + { ctx with canevas } let write_revision (Coord (x, y)) rev ctx = - {ctx with canevas= - match rev with - | First s -> - P.paint_text s Orient_H + { + ctx with + canevas = + (match rev with + | First s -> + P.paint_text s Orient_H (Coord (x, y + 50)) (Size 50) J_left NoStyle ctx.canevas - | Second s -> - P.paint_text s Orient_H + | Second s -> + P.paint_text s Orient_H (Coord (x + 2200, y + 50)) (Size 50) J_left NoStyle ctx.canevas - | No_Rev -> ctx.canevas + | No_Rev -> ctx.canevas); } - let draw_sheet_field name number ((Size size) as s) (Coord (x, y)) (Coord (_, dim_y)) ctx = + let draw_sheet_field name number (Size size as s) (Coord (x, y)) + (Coord (_, dim_y)) ctx = let y = if number = 0 then y else y + dim_y + size in - let canevas = P.paint_text name Orient_H - (Coord (x, y)) - s J_left NoStyle ctx.canevas - in {ctx with canevas} + let canevas = + P.paint_text name Orient_H (Coord (x, y)) s J_left NoStyle ctx.canevas + in + { ctx with canevas } let draw_sheet_rect c dim ctx = - {ctx with canevas=P.paint_rect c dim ctx.canevas} + { ctx with canevas = P.paint_rect c dim ctx.canevas } let draw_label line l c : t = match l.labeltype with @@ -512,8 +519,12 @@ struct l.size l.orient NoStyle c' in let lines = split_lines line in - {c with canevas= - List.fold_left paint_line c.canevas (List.mapi (fun i l -> (i, l)) lines)} + { + c with + canevas = + List.fold_left paint_line c.canevas + (List.mapi (fun i l -> (i, l)) lines); + } | PortLabel (prange, ptype) -> let pcolor = match prange with Glabel -> `Green | Hlabel -> `Red in let new_type = swap_type ptype in @@ -521,5 +532,5 @@ struct let modify_canevas f ctx = let canevas, is_multi = f ctx.canevas in - {ctx with canevas}, is_multi + ({ ctx with canevas }, is_multi) end diff --git a/kicadsch/src/schparse.ml b/kicadsch/src/schparse.ml index afc2af5..99fe5e1 100644 --- a/kicadsch/src/schparse.ml +++ b/kicadsch/src/schparse.ml @@ -1,14 +1,14 @@ -(** This function generates a parsing function which outputs an 'a - option Note that some lines may not yield any correct output, so - the output is an option. **) +(** This function generates a parsing function which outputs an 'a option Note + that some lines may not yield any correct output, so the output is an + option. **) let create_lib_parse_fun ~name ~regexp_str ~processing = let parser line = try Scanf.sscanf line regexp_str processing with | End_of_file -> - Printf.printf "could not match %s (%s): line to short\n" name line ; + Printf.printf "could not match %s (%s): line to short\n" name line; None | Scanf.Scan_failure m -> - Printf.printf "could not match %s (%s): %s\n" name line m ; + Printf.printf "could not match %s (%s): %s\n" name line m; None in parser @@ -18,16 +18,15 @@ let create_parse_fun ~name ~regexp_str ~extract_fun = try match Scanf.sscanf line regexp_str extract_fun with | None -> - Printf.printf "Fields of %s could not be parsed (%s)\n" name line ; + Printf.printf "Fields of %s could not be parsed (%s)\n" name line; onerror () - | Some args -> - process args + | Some args -> process args with | End_of_file -> - Printf.printf "could not match %s (%s): line to short\n" name line ; + Printf.printf "could not match %s (%s): line to short\n" name line; onerror () | Scanf.Scan_failure m -> - Printf.printf "could not match %s (%s): %s\n" name line m ; + Printf.printf "could not match %s (%s): %s\n" name line m; onerror () in parser @@ -39,9 +38,7 @@ let parse_list ?(cond = fun _ -> true) form s = let new_val = Scanf.bscanf stream form (fun x -> x) in if cond new_val then do_parse (new_val :: acc) else acc with - | Scanf.Scan_failure _ -> - acc - | End_of_file -> - acc + | Scanf.Scan_failure _ -> acc + | End_of_file -> acc in do_parse [] diff --git a/kicadsch/src/sexpKicadSch.ml b/kicadsch/src/sexpKicadSch.ml index 2da689b..f797708 100644 --- a/kicadsch/src/sexpKicadSch.ml +++ b/kicadsch/src/sexpKicadSch.ml @@ -2,192 +2,153 @@ open KicadDefs module Sigs = KicadSch_sigs open Sigs open KicadLib_sigs -module Decode = Sexp_decode.Make(Base.Sexp) +module Decode = Sexp_decode.Make (Base.Sexp) open Decode open! StdLabels - let mm_size x = int_of_float (x *. 100.) let wx_size x = int_of_float (x *. 100.) +let coords = float <*> float >>| fun (x, y) -> Coord (wx_size x, wx_size y) +let dist_expr s = field s float >>| fun s -> wx_size s +let length_expr = dist_expr "length" -let coords = float <*> float >>| (fun (x, y) -> Coord (wx_size x, wx_size y)) - - -let dist_expr s = - field s float >>| (fun s -> wx_size s) -let length_expr = - dist_expr "length" - -type kolor = {red: int; green: int; blue: int; alpha: float} +type kolor = { red : int; green : int; blue : int; alpha : float } type width = Width of int let kolor_args = - let+ colors = tuple4 int int int float in + let+ colors = tuple4 int int int float in let red, green, blue, alpha = colors in - {red; green; blue; alpha} + { red; green; blue; alpha } let kolor_expr = field "color" kolor_args +let uuid_args = + string ~escaped:false >>= fun s -> + match Uuidm.of_string s with + | Some u -> return u + | None -> failwith "Not a uuid" -let uuid_args = (string ~escaped:false) >>= (fun s -> match Uuidm.of_string s with Some u -> return u | None -> failwith "Not a uuid") -let gen_uuid_expr s = - field s uuid_args - +let gen_uuid_expr s = field s uuid_args let uuid_expr = gen_uuid_expr "uuid" let page_UUID_expr = gen_uuid_expr "uuid" let page_expr = field "page" (string ~escaped:false) -;; let paper_size_args = let* s = string ~escaped:false in - let* size = maybe (coords) in + let* size = maybe coords in let+ p = maybe (tag "portrait") in - - let Coord(x, y) as c = match s with - | "A5" -> (Coord ((mm_size 210.), (mm_size 148.))) - | "A4" -> (Coord ((mm_size 297.), (mm_size 210.))) - | "A3" -> (Coord((mm_size 420. ), (mm_size 297. ))) - | "A2" -> (Coord((mm_size 594. ), (mm_size 420. ))) - | "A1" -> (Coord((mm_size 841. ), (mm_size 594. ))) - | "A0" -> (Coord((mm_size 1189. ), (mm_size 841. ))) - | "A" -> (Coord((wx_size 11000.), (wx_size 8500.))) - | "B" -> (Coord((wx_size 17000.), (wx_size 11000.))) - | "C" -> (Coord((wx_size 22000.), (wx_size 17000.))) - | "D" -> (Coord((wx_size 34000.), (wx_size 22000.))) - | "E" -> (Coord((wx_size 44000.), (wx_size 34000.))) -(* | "GERBER" -> coords *) - | "User" -> (match size with Some coords -> coords | None -> failwith "User paper size requires a size") - - | "USLetter" -> (Coord((wx_size 11000.), (wx_size 8500.))) - | "USLegal" -> (Coord((wx_size 14000.), (wx_size 8500.))) - | "USLedger" -> (Coord((wx_size 17000.), (wx_size 11000.))) - | s -> failwith ("unknown paper size " ^ s) in - match p with Some _ -> (Coord(y, x)) | None -> c - -;; -let paper_expr = - field "paper" paper_size_args -;; -let xy_expr = - field "xy" coords - -let pts_expr = - field "pts" (repeat_full_list xy_expr) - -let make_rel (Coord(x,y)) = RelCoord(x,y) -let make_rel_pts pts = - List.map ~f:make_rel pts -;; - -let string_expr s = - field s (string ~escaped:false) - -let int_expr s = - field s int - -let float_expr s = - field s float - - (* (s yes) (s no) or (s) *) + let (Coord (x, y) as c) = + match s with + | "A5" -> Coord (mm_size 210., mm_size 148.) + | "A4" -> Coord (mm_size 297., mm_size 210.) + | "A3" -> Coord (mm_size 420., mm_size 297.) + | "A2" -> Coord (mm_size 594., mm_size 420.) + | "A1" -> Coord (mm_size 841., mm_size 594.) + | "A0" -> Coord (mm_size 1189., mm_size 841.) + | "A" -> Coord (wx_size 11000., wx_size 8500.) + | "B" -> Coord (wx_size 17000., wx_size 11000.) + | "C" -> Coord (wx_size 22000., wx_size 17000.) + | "D" -> Coord (wx_size 34000., wx_size 22000.) + | "E" -> Coord (wx_size 44000., wx_size 34000.) + (* | "GERBER" -> coords *) + | "User" -> ( + match size with + | Some coords -> coords + | None -> failwith "User paper size requires a size") + | "USLetter" -> Coord (wx_size 11000., wx_size 8500.) + | "USLegal" -> Coord (wx_size 14000., wx_size 8500.) + | "USLedger" -> Coord (wx_size 17000., wx_size 11000.) + | s -> failwith ("unknown paper size " ^ s) + in + match p with Some _ -> Coord (y, x) | None -> c + +let paper_expr = field "paper" paper_size_args +let xy_expr = field "xy" coords +let pts_expr = field "pts" (repeat_full_list xy_expr) +let make_rel (Coord (x, y)) = RelCoord (x, y) +let make_rel_pts pts = List.map ~f:make_rel pts +let string_expr s = field s (string ~escaped:false) +let int_expr s = field s int +let float_expr s = field s float + +(* (s yes) (s no) or (s) *) let yesno_expr s = - field s (maybe atom) >>= (function | Some "yes" -> return true | Some "no" -> return false | _ -> return true) - -;; + field s (maybe atom) >>= function + | Some "yes" -> return true + | Some "no" -> return false + | _ -> return true let pin_at_coord_args = let+ at_coords = tuple3 float float (maybe int) in let x, y, angle = at_coords in - Coord (wx_size x, wx_size y), Option.value ~default:0 angle + (Coord (wx_size x, wx_size y), Option.value ~default:0 angle) let pin_at_coord_expr = field "at" pin_at_coord_args -;; - -type fill_type = - | No_fill - | Background_fill - | Outline_fill +type fill_type = No_fill | Background_fill | Outline_fill -let fill_type_atom = atom >>= function - | "none" -> return No_fill - | "background" -> return Background_fill - | "outline" -> return Outline_fill - | _ -> error +let fill_type_atom = + atom >>= function + | "none" -> return No_fill + | "background" -> return Background_fill + | "outline" -> return Outline_fill + | _ -> error let fill_type_expr = field "type" fill_type_atom -type fill = - { - fill_type: fill_type option - ; kolor: kolor option - } +type fill = { fill_type : fill_type option; kolor : kolor option } -let fill_expr: fill decoder = +let fill_expr : fill decoder = field "fill" - (fields ~default:({fill_type=None; kolor=None}:fill) - [ - ("type", fill_type_atom >>| (fun fill_t arg -> {arg with fill_type=Some fill_t})) - ; ("color", kolor_args >>| (fun color arg -> {arg with kolor=Some color})) - ] - ) - -;; + (fields + ~default:({ fill_type = None; kolor = None } : fill) + [ + ( "type", + fill_type_atom >>| fun fill_t arg -> + { arg with fill_type = Some fill_t } ); + ( "color", + kolor_args >>| fun color arg -> { arg with kolor = Some color } ); + ]) let horizontal_justify_atom = - atom >>= - function - | "left" -> - return J_left - | "right" -> - return J_right - | "center" -> - return J_center - | _ -> - error + atom >>= function + | "left" -> return J_left + | "right" -> return J_right + | "center" -> return J_center + | _ -> error let vertical_justify_atom = - atom >>= - function - | "top" -> return J_top - | "bottom" -> return J_bottom - | "center" -> return J_center - | _ -> - error - -type justification = - { - horiz: justify option - ; vert: justify option - } + atom >>= function + | "top" -> return J_top + | "bottom" -> return J_bottom + | "center" -> return J_center + | _ -> error + +type justification = { horiz : justify option; vert : justify option } let justify_args = - let+ justif = tuple2 (maybe horizontal_justify_atom) (maybe vertical_justify_atom) in + let+ justif = + tuple2 (maybe horizontal_justify_atom) (maybe vertical_justify_atom) + in let horiz, vert = justif in - {horiz; vert} + { horiz; vert } let justify_expr = field "justify" justify_args -;; - -type font_def = - { - font: string option - ; size: coord - ; italic: bool - ; bold: bool - ; kolor: kolor option - } +type font_def = { + font : string option; + size : coord; + italic : bool; + bold : bool; + kolor : kolor option; +} let size_expr = field "size" coords - -let opt_to_bool = function - | Some _ -> true - | None -> false +let opt_to_bool = function Some _ -> true | None -> false (* Accept either a yes/no field form "(name yes|no)" (V8) or a bare tag atom "name" (V6/V7). Both produce a bool; bare tag always means true. *) -let bool_or_tag name = - (yesno_expr name) |+> (tag name >>| fun _ -> true) +let bool_or_tag name = yesno_expr name |+> (tag name >>| fun _ -> true) let font_args = let* font = maybe (field "face" (string ~escaped:false)) in @@ -195,104 +156,89 @@ let font_args = let* _line_spacing = maybe (field "line_spacing" float) in let* _thickness = maybe (field "thickness" skip) in let* italic = maybe (bool_or_tag "italic") >>| opt_to_bool in - let* bold = maybe (bool_or_tag "bold") >>| opt_to_bool in + let* bold = maybe (bool_or_tag "bold") >>| opt_to_bool in let+ kolor = maybe kolor_expr in - {font; size; italic; bold; kolor} + { font; size; italic; bold; kolor } let font_expr = field "font" font_args -;; - -let optional_hide_atom = (maybe @@ tag "hide") >>| opt_to_bool +let optional_hide_atom = maybe @@ tag "hide" >>| opt_to_bool -type effects = - { - font: font_def - ; justify: justification option - ; hide: bool - } +type effects = { font : font_def; justify : justification option; hide : bool } let effects_args = let* font = font_expr in let* justify = maybe justify_expr in let+ hide = maybe (bool_or_tag "hide") >>| opt_to_bool in (* If both are set, we take the first one, so we can use the "hide" tag in the font definition *) - {font; justify; hide } + { font; justify; hide } let effects_expr = field "effects" effects_args let justify_of_justification j = - let justify = Option.value j ~default:{horiz=None; vert=None} in + let justify = Option.value j ~default:{ horiz = None; vert = None } in Option.value ~default:J_center justify.horiz let justify_of_effect e = justify_of_justification e.justify -let fontsize_of_effect e = let Coord (_x, y) = e.font.size in y -;; +let fontsize_of_effect e = + let (Coord (_x, y)) = e.font.size in + y let style_args = - atom >>= fun s -> match s with - | "default" - | "solid" - | "dash" - | "dot" - | "dash_dot" - | "dash_dot_dot" -> return s + atom >>= fun s -> + match s with + | "default" | "solid" | "dash" | "dot" | "dash_dot" | "dash_dot_dot" -> + return s | _ -> error -let line_style_expr = - field "type" style_args - +let line_style_expr = field "type" style_args let optional_line_style_expr = maybe @@ field "solid" line_style_expr -let width_expr = float_expr "width" >>| (fun w -> let width = wx_size w in Width width) +let width_expr = + float_expr "width" >>| fun w -> + let width = wx_size w in + Width width + let optional_width_expr = maybe width_expr -type stroke = - { - width: width option - ; kolor: kolor option - ; style: string option - } +type stroke = { + width : width option; + kolor : kolor option; + style : string option; +} let stroke_args = let* width = maybe width_expr in let* style = maybe line_style_expr in let+ kolor = maybe kolor_expr in - {kolor; style; width} + { kolor; style; width } -let stroke_expr = - field "stroke" stroke_args - -;; +let stroke_expr = field "stroke" stroke_args let optional_stroke_to_width = function - | None - | Some {width=None; _} -> 10 - | Some {width=Some (Width w); _} -> w + | None | Some { width = None; _ } -> 10 + | Some { width = Some (Width w); _ } -> w let default_width = 10 -;; - -type property = - { - name: string - ; value: string - ; id: int - ; at : coord - ; rot: int - ; effects: effects option - } +type property = { + name : string; + value : string; + id : int; + at : coord; + rot : int; + effects : effects option; +} let property_build _name _ text _id at effects = match effects with - | None - | Some {hide=true; _} -> None - | _ -> Some ( - let c = make_rel at in - Text {text; c; s=Size 1}) + | None | Some { hide = true; _ } -> None + | _ -> + Some + (let c = make_rel at in + Text { text; c; s = Size 1 }) -let field_build {name; value; id; at; rot; effects} = +let field_build { name; value; id; at; rot; effects } = let _ = name in let nb = id in let text = value in @@ -301,20 +247,25 @@ let field_build {name; value; id; at; rot; effects} = match rot with | 0 | 180 -> Orient_H | 90 | 270 -> Orient_V - | _ -> raise Not_found in - let s, j, stl, hide = match effects with - | None -> Size default_width, J_left, NoStyle, false + | _ -> raise Not_found + in + let s, j, stl, hide = + match effects with + | None -> (Size default_width, J_left, NoStyle, false) | Some ef -> - let j = justify_of_effect ef in - let Coord (_, y)= ef.font.size in - let s = Size y in - let style = match ef.font.italic, ef.font.bold with - | true, false -> Italic - | false, true -> Bold - | true, true -> BoldItalic - | false, false -> NoStyle - in s, j, style, ef.hide in - if hide then None else Some {nb; text; co; o; s; j; stl} + let j = justify_of_effect ef in + let (Coord (_, y)) = ef.font.size in + let s = Size y in + let style = + match (ef.font.italic, ef.font.bold) with + | true, false -> Italic + | false, true -> Bold + | true, true -> BoldItalic + | false, false -> NoStyle + in + (s, j, style, ef.hide) + in + if hide then None else Some { nb; text; co; o; s; j; stl } let property_args = let* name = string ~escaped:false in @@ -324,54 +275,53 @@ let property_args = let* _ = maybe (bool_or_tag "do_not_autoplace") in let+ effects = maybe effects_expr in let id = Option.value ~default:0 id_opt in - {name; value; id; at; rot; effects} + { name; value; id; at; rot; effects } let property_expr = field "property" property_args -;; - let text_gen_args = let* text = string ~escaped:false in let* _exclude_from_sim = maybe (yesno_expr "exclude_from_sim") in let* coords, rot = pin_at_coord_expr in let* effects = effects_expr in let+ _uuid = maybe uuid_expr in - let Coord (size, _) = effects.font.size in + let (Coord (size, _)) = effects.font.size in let justify = justify_of_justification effects.justify in - coords, text, Size size, rot, justify + (coords, text, Size size, rot, justify) -let text_args = text_gen_args >>| (fun (coords, text, size, _rot, _justify) -> - Text {c=make_rel coords; text; s=size }) +let text_args = + text_gen_args >>| fun (coords, text, size, _rot, _justify) -> + Text { c = make_rel coords; text; s = size } let text_expr = field "text" text_args -;; - let polyline_args = let* pts = pts_expr in let* stroke = maybe stroke_expr in let* _fill = maybe fill_expr in let+ _uuid = maybe uuid_expr in - (optional_stroke_to_width stroke), pts - -let polyline_expr = - field "polyline" polyline_args - -;; - -let start_point_expr = - field "start" coords - -let end_point_expr = - field "end" coords + (optional_stroke_to_width stroke, pts) + +let polyline_expr = field "polyline" polyline_args +let start_point_expr = field "start" coords +let end_point_expr = field "end" coords + +let rect_to_polyline (Coord (xs, ys), Coord (xe, ye), s, _) = + let points = + [ + RelCoord (xs, ys); + RelCoord (xs, ye); + RelCoord (xe, ye); + RelCoord (xe, ys); + RelCoord (xs, ys); + ] + in + let width = optional_stroke_to_width s in + Polygon (width, points) -let rect_to_polyline ((Coord(xs, ys)), (Coord(xe, ye)), s, _) = - let points = [RelCoord(xs, ys); RelCoord(xs, ye); RelCoord (xe, ye); RelCoord(xe, ys); RelCoord(xs, ys)] in - let width = optional_stroke_to_width s - in Polygon (width, points) +let rect_to_sheet_rec (Coord (xs, ys), Coord (xe, ye), _s, _) = + (Coord (xs, ys), Coord (xe - xs, ye - ys)) -let rect_to_sheet_rec ((Coord(xs, ys)), (Coord(xe, ye)), _s, _) = - (Coord(xs, ys), Coord(xe -xs, ye - ys)) let gen_rectangle_args = let* start_point = start_point_expr in let* end_point = end_point_expr in @@ -381,50 +331,26 @@ let gen_rectangle_args = (start_point, end_point, s, fill) let rectangle_prim_args = gen_rectangle_args >>| rect_to_polyline - let rectangle_args = gen_rectangle_args >>| rect_to_sheet_rec - -let rectangle_expr = field - "rectangle" rectangle_args - -let rectangle_prim_expr = field - "rectangle" rectangle_prim_args -;; - -let pin_tag_expr s = field s (string ~escaped:false <*>effects_expr) +let rectangle_expr = field "rectangle" rectangle_args +let rectangle_prim_expr = field "rectangle" rectangle_prim_args +let pin_tag_expr s = field s (string ~escaped:false <*> effects_expr) let pin_type_atom = - atom >>| - function - | "bidirectional" - | "passive" - | "input" - | "output" - | "power_in" - | "power_out" - | "open_collector" - | "open_drain" - | "open_emitter" - | "emitter_follower" - | "source_follower" - | "unconnected" - | "no_connect" - | "tri_state" - | "unspecified" -> true - | s -> failwith (Printf.sprintf "no match for pin type (%s)" s) + atom >>| function + | "bidirectional" | "passive" | "input" | "output" | "power_in" | "power_out" + | "open_collector" | "open_drain" | "open_emitter" | "emitter_follower" + | "source_follower" | "unconnected" | "no_connect" | "tri_state" + | "unspecified" -> + true + | s -> failwith (Printf.sprintf "no match for pin type (%s)" s) let pin_shape_atom = atom >>| function - | "none" - | "line" - | "inverted" - | "clock" - | "inverted_clk" - | "input_low" - | "clock_low" - | "falling_edge" - | "non_logic" -> true - | s -> failwith (Printf.sprintf "no match for pin shape (%s)" s) + | "none" | "line" | "inverted" | "clock" | "inverted_clk" | "input_low" + | "clock_low" | "falling_edge" | "non_logic" -> + true + | s -> failwith (Printf.sprintf "no match for pin shape (%s)" s) let pin_alternate_args = field "alternate" @@ -436,11 +362,12 @@ let pin_args = let* c, a = pin_at_coord_expr in let* s = field "length" float in let* _hide = maybe (bool_or_tag "hide") in - let* (name_str, name_effect) = pin_tag_expr "name" in - let* (number_str, number_effect) = pin_tag_expr "number" in + let* name_str, name_effect = pin_tag_expr "name" in + let* number_str, number_effect = pin_tag_expr "number" in let+ _alts = repeat_full_list pin_alternate_args in let contact = make_rel c in - let orient = match a with + let orient = + match a with | 0 -> P_R | 90 -> P_U | 180 -> P_L @@ -449,54 +376,46 @@ let pin_args = in let length = Size (wx_size s) in let name = - let Coord(x, _) = name_effect.font.size - in name_str, (Size x) + let (Coord (x, _)) = name_effect.font.size in + (name_str, Size x) in let number = - let Coord(x, _) = number_effect.font.size - in number_str, (Size x) + let (Coord (x, _)) = number_effect.font.size in + (number_str, Size x) in - Pin {name; number; length; contact; orient} + Pin { name; number; length; contact; orient } let pin_expr = field "pin" pin_args - -;; - let angles_expr = field "angles" (float <*> float) - -;; - let at_expr = field "at" coords let radius_args = - let* at = at_expr >>| make_rel in + let* at = at_expr >>| make_rel in let* length = length_expr in let+ angles = angles_expr in - at, length, angles - -let radius_expr = - field "radius" radius_args - -;; + (at, length, angles) -let mid_point_expr = - field "mid" coords >>| make_rel +let radius_expr = field "radius" radius_args +let mid_point_expr = field "mid" coords >>| make_rel -let arc_center_radius_from_rel_points - (RelCoord (ax, ay)) (RelCoord (bx, by)) (RelCoord (cx, cy)) = +let arc_center_radius_from_rel_points (RelCoord (ax, ay)) (RelCoord (bx, by)) + (RelCoord (cx, cy)) = let ax = float_of_int ax and ay = float_of_int ay in let bx = float_of_int bx and by = float_of_int by in let cx = float_of_int cx and cy = float_of_int cy in - let d = 2.0 *. ((bx -. ax) *. (cy -. by) -. (cx -. bx) *. (by -. ay)) in + let d = 2.0 *. (((bx -. ax) *. (cy -. by)) -. ((cx -. bx) *. (by -. ay))) in if Float.abs d < 1e-3 then None else - let ab2 = bx *. bx +. by *. by -. ax *. ax -. ay *. ay in - let bc2 = cx *. cx +. cy *. cy -. bx *. bx -. by *. by in - let ux = (ab2 *. (cy -. by) -. bc2 *. (by -. ay)) /. d in - let uy = ((bx -. ax) *. bc2 -. (cx -. bx) *. ab2) /. d in - let r = Float.sqrt ((ux -. ax) *. (ux -. ax) +. (uy -. ay) *. (uy -. ay)) in - Some (RelCoord (Float.to_int (Float.round ux), Float.to_int (Float.round uy)), - Float.to_int (Float.round r)) + let ab2 = (bx *. bx) +. (by *. by) -. (ax *. ax) -. (ay *. ay) in + let bc2 = (cx *. cx) +. (cy *. cy) -. (bx *. bx) -. (by *. by) in + let ux = ((ab2 *. (cy -. by)) -. (bc2 *. (by -. ay))) /. d in + let uy = (((bx -. ax) *. bc2) -. ((cx -. bx) *. ab2)) /. d in + let r = + Float.sqrt (((ux -. ax) *. (ux -. ax)) +. ((uy -. ay) *. (uy -. ay))) + in + Some + ( RelCoord (Float.to_int (Float.round ux), Float.to_int (Float.round uy)), + Float.to_int (Float.round r) ) let arc_args = let* sp = start_point_expr >>| make_rel in @@ -509,21 +428,18 @@ let arc_args = let s = Size width in let center, radius = match radius_group with - | Some (at, length, _angles) -> at, length - | None -> - (match mid with - | Some mid_pt -> - (match arc_center_radius_from_rel_points sp mid_pt ep with - | Some (c, r) -> c, r - | None -> failwith "arc: start, mid, end points are collinear") - | None -> failwith "arc: either radius or mid point must be specified") - in Arc { sp; ep; s; radius; center} - - -let arc_expr = - field "arc" arc_args + | Some (at, length, _angles) -> (at, length) + | None -> ( + match mid with + | Some mid_pt -> ( + match arc_center_radius_from_rel_points sp mid_pt ep with + | Some (c, r) -> (c, r) + | None -> failwith "arc: start, mid, end points are collinear") + | None -> failwith "arc: either radius or mid point must be specified") + in + Arc { sp; ep; s; radius; center } -;; +let arc_expr = field "arc" arc_args let bezier_args = let* pts = pts_expr in @@ -532,15 +448,8 @@ let bezier_args = let points = make_rel_pts pts in Bezier (optional_stroke_to_width stroke, points) - - -let bezier_expr = - field "gr_curve" bezier_args - -;; - -let center_expr = - field "center" coords >>| make_rel +let bezier_expr = field "gr_curve" bezier_args +let center_expr = field "center" coords >>| make_rel let circle_args = let* center = center_expr in @@ -548,78 +457,97 @@ let circle_args = let* stroke = maybe stroke_expr in let+ _fill = maybe fill_expr in let width = optional_stroke_to_width stroke in - Circle (width, {center; radius}) - -let circle_expr = - field "circle" circle_args + Circle (width, { center; radius }) -;; +let circle_expr = field "circle" circle_args (* V8 schematic ellipse: (center x y) (major_radius r) (minor_radius r) (rotation_angle deg) *) let ellipse_common_args = let* center = field "center" coords in - let* major_radius = field "major_radius" float >>| (fun r -> Float.to_int (Float.round (r *. 100.0))) in - let* minor_radius = field "minor_radius" float >>| (fun r -> Float.to_int (Float.round (r *. 100.0))) in - let+ rotation_angle = field "rotation_angle" float >>| Float.round >>| int_of_float in + let* major_radius = + field "major_radius" float >>| fun r -> + Float.to_int (Float.round (r *. 100.0)) + in + let* minor_radius = + field "minor_radius" float >>| fun r -> + Float.to_int (Float.round (r *. 100.0)) + in + let+ rotation_angle = + field "rotation_angle" float >>| Float.round >>| int_of_float + in (center, major_radius, minor_radius, rotation_angle) let sch_ellipse_args = - let* (center, ma, mi, rot) = ellipse_common_args in + let* center, ma, mi, rot = ellipse_common_args in let* _stroke = maybe stroke_expr in - let* _fill = maybe fill_expr in - let* _uuid = maybe uuid_expr in + let* _fill = maybe fill_expr in + let* _uuid = maybe uuid_expr in let+ _locked = maybe (yesno_expr "locked") in (center, ma, mi, rot) let sch_ellipse_arc_args = - let* (center, ma, mi, rot) = ellipse_common_args in - let* start_angle = field "start_angle" float >>| Float.round >>| int_of_float in - let* end_angle = field "end_angle" float >>| Float.round >>| int_of_float in + let* center, ma, mi, rot = ellipse_common_args in + let* start_angle = + field "start_angle" float >>| Float.round >>| int_of_float + in + let* end_angle = field "end_angle" float >>| Float.round >>| int_of_float in let* _stroke = maybe stroke_expr in - let* _fill = maybe fill_expr in - let* _uuid = maybe uuid_expr in + let* _fill = maybe fill_expr in + let* _uuid = maybe uuid_expr in let+ _locked = maybe (yesno_expr "locked") in (center, ma, mi, rot, start_angle, end_angle) -;; - (* Library symbol ellipse primitive: (center x y) (major_radius r) (minor_radius r) (rotation_angle deg) *) let ellipse_prim_args = let* center = center_expr in let* major_radius = dist_expr "major_radius" in let* minor_radius = dist_expr "minor_radius" in - let* rotation_angle = field "rotation_angle" float >>| Float.round >>| int_of_float in + let* rotation_angle = + field "rotation_angle" float >>| Float.round >>| int_of_float + in let* stroke = maybe stroke_expr in let+ _fill = maybe fill_expr in let width = optional_stroke_to_width stroke in - Ellipse (width, {center; major_radius; minor_radius; rotation_angle}) + Ellipse (width, { center; major_radius; minor_radius; rotation_angle }) let ellipse_arc_prim_args = let* center = center_expr in let* major_radius = dist_expr "major_radius" in let* minor_radius = dist_expr "minor_radius" in - let* rotation_angle = field "rotation_angle" float >>| Float.round >>| int_of_float in - let* start_angle = field "start_angle" float >>| Float.round >>| int_of_float in - let* end_angle = field "end_angle" float >>| Float.round >>| int_of_float in + let* rotation_angle = + field "rotation_angle" float >>| Float.round >>| int_of_float + in + let* start_angle = + field "start_angle" float >>| Float.round >>| int_of_float + in + let* end_angle = field "end_angle" float >>| Float.round >>| int_of_float in let* stroke = maybe stroke_expr in let+ _fill = maybe fill_expr in let width = optional_stroke_to_width stroke in - EllipseArc (width, {center; major_radius; minor_radius; rotation_angle; start_angle; end_angle}) - -;; + EllipseArc + ( width, + { + center; + major_radius; + minor_radius; + rotation_angle; + start_angle; + end_angle; + } ) let primitive = - variant - [ ("polyline", polyline_args >>| (fun (s,l) -> Polygon (s, make_rel_pts l))) - ; ("circle", circle_args) - ; ("ellipse", ellipse_prim_args) - ; ("ellipse_arc", ellipse_arc_prim_args) - ; ("arc", arc_args) - ; ("bezier", bezier_args) - ; ("pin", pin_args) - ; ("text", text_args) - ; ("rectangle", rectangle_prim_args) - ] + variant + [ + ("polyline", polyline_args >>| fun (s, l) -> Polygon (s, make_rel_pts l)); + ("circle", circle_args); + ("ellipse", ellipse_prim_args); + ("ellipse_arc", ellipse_arc_prim_args); + ("arc", arc_args); + ("bezier", bezier_args); + ("pin", pin_args); + ("text", text_args); + ("rectangle", rectangle_prim_args); + ] let extend_expr = string_expr "extends" @@ -627,20 +555,24 @@ let unit_args = let* name = string ~escaped:false in let+ graphics = repeat_full_list primitive in match List.rev (String.split_on_char ~sep:'_' name) with - | _style::part_str::_ -> let parts=int_of_string part_str in - List.map ~f:(fun prim -> {parts; prim}) graphics + | _style :: part_str :: _ -> + let parts = int_of_string part_str in + List.map ~f:(fun prim -> { parts; prim }) graphics | _ -> failwith ("malformed unit: " ^ name) let unit_expr = field "symbol" unit_args +let unit_peek expr = peek expr >>= function Some _ -> return () | _ -> error -;; - -let unit_peek expr = peek expr >>= function | Some _ -> return () | _ -> error +let pin_number_hide_expr = + maybe_with_default false @@ (field "pin_numbers" skip >>= fun _ -> return true) -let pin_number_hide_expr = maybe_with_default false @@ ((field "pin_numbers" skip) >>= (fun _ -> return true)) let offset_expr = maybe_with_default 0 @@ dist_expr "offset" -let pin_names_expr = maybe_with_default true @@ (field "pin_names" (offset_expr <*> maybe skip) >>= fun _ -> return false) -let exclude_from_sim_expr = maybe (yesno_expr "exclude_from_sim") + +let pin_names_expr = + maybe_with_default true + @@ (field "pin_names" (offset_expr <*> maybe skip) >>= fun _ -> return false) + +let exclude_from_sim_expr = maybe (yesno_expr "exclude_from_sim") let in_bom_expr = yesno_expr "in_bom" let on_board_expr = yesno_expr "on_board" @@ -654,31 +586,32 @@ let symbol_args = let* _in_bom = in_bom_expr in let* _on_board = on_board_expr in let* _properties = repeat_list ~until:(unit_peek unit_expr) property_expr in - let+ units = repeat_full_list (unit_expr |+> (field "embedded_fonts" (skip >>| fun _ -> []))) in - let graph = List.flatten units in - {names=[name]; draw_pnum= not hide_pin_numbers; draw_pname; multi=false; graph} + let+ units = + repeat_full_list + (unit_expr |+> field "embedded_fonts" (skip >>| fun _ -> [])) + in + let graph = List.flatten units in + { + names = [ name ]; + draw_pnum = not hide_pin_numbers; + draw_pname; + multi = false; + graph; + } let symbol_expr = field "symbol" symbol_args - -;; - let lib_symbols_args = repeat_full_list symbol_expr - let lib_symbols_expr = field "lib_symbols" lib_symbols_args -;; - let junction_args = let* position = at_expr in let* _diameter = field "diameter" float in let* _color = kolor_expr in - let+ _uuid = maybe uuid_expr - in position + let+ _uuid = maybe uuid_expr in + position let junction_expr = field "junction" junction_args -;; - let no_connect_args = let* position = at_expr in let+ _uuid = maybe uuid_expr in @@ -686,18 +619,17 @@ let no_connect_args = let no_connect_expr = field "no_connect" no_connect_args -;; - let bus_entry_args = let* position = at_expr in - let* size = field "size" (tuple2 float float) >>| (fun (s1, s2) -> mm_size s1, mm_size s2) in + let* size = + field "size" (tuple2 float float) >>| fun (s1, s2) -> + (mm_size s1, mm_size s2) + in let* _stroke = stroke_expr in let+ _uuid = maybe uuid_expr in - position, size + (position, size) - let bus_entry_expr = field "bus_entry" bus_entry_args - -;; +let bus_entry_expr = field "bus_entry" bus_entry_args let bus_wire_args = let* pts = pts_expr in @@ -708,9 +640,6 @@ let bus_wire_args = let bus_expr = field "bus" bus_wire_args let wire_expr = field "wire" bus_wire_args -;; -;; - let label_args = let* text = string ~escaped:false in let* _exclude_from_sim = maybe (yesno_expr "exclude_from_sim") in @@ -718,21 +647,17 @@ let label_args = let* _autoplaced = maybe (field "fields_autoplaced" skip_all) in let* effects = effects_expr in let+ _uuid = maybe uuid_expr in - let Coord (size, _) = effects.font.size in + let (Coord (size, _)) = effects.font.size in (coords, rot, text, Size size, justify_of_justification effects.justify) -;; - -let shape_args = string ~escaped:false >>| (function - | "input" -> InputPort - | "output" -> OutputPort - | "bidirectional" -> BiDiPort - | "tri_state" -> ThreeStatePort - | "passive" -> ThreeStatePort - | s -> failwith ("unknown shape " ^ s) - ) - -;; +let shape_args = + string ~escaped:false >>| function + | "input" -> InputPort + | "output" -> OutputPort + | "bidirectional" -> BiDiPort + | "tri_state" -> ThreeStatePort + | "passive" -> ThreeStatePort + | s -> failwith ("unknown shape " ^ s) let hierarchical_label_args = let* text = string ~escaped:false in @@ -742,20 +667,18 @@ let hierarchical_label_args = let* effects = effects_expr in let* _uuid = maybe uuid_expr in let+ _prop = maybe (repeat_full_list property_expr) in - let Coord (size, _) = effects.font.size in + let (Coord (size, _)) = effects.font.size in (coords, rot, text, Size size, shape, justify_of_justification effects.justify) let global_label_expr = field "global_label" hierarchical_label_args -;; - let sch_pin_args = let* name = string ~escaped:false in let+ _id = uuid_expr in name let sch_pin_expr = field "pin" sch_pin_args -;; + (* let path_instance_args = let* _path_name = string ~escaped:false in @@ -776,46 +699,69 @@ let path_instance_expr = field "path" path_instance_args let project_args = let* _project_name = string ~escaped:false in - let+ _paths = (repeat1_full_list path_instance_expr) in + let+ _paths = repeat1_full_list path_instance_expr in () let project_instance_expr = field "project" project_args - -let instances_args = repeat1_full_list project_instance_expr >>| (fun _ -> 0 ) - +let instances_args = repeat1_full_list project_instance_expr >>| fun _ -> 0 let instances_expr = field "instances" instances_args -type lib_sym = {lib_id: string; lib_name: string option; pos: coord; rot: int; unit_nr: int; properties: property list; mirror_x: bool; mirror_y: bool} +type lib_sym = { + lib_id : string; + lib_name : string option; + pos : coord; + rot : int; + unit_nr : int; + properties : property list; + mirror_x : bool; + mirror_y : bool; +} let sch_symbol_args = let* lib_name = maybe (string_expr "lib_name") in - let* lib_id = string_expr "lib_id" in - let+ lib_sym = fields - ~default: {lib_id; lib_name; pos= Coord(0,0); rot=0; unit_nr=1; properties=[]; mirror_x=false; mirror_y=false} + let* lib_id = string_expr "lib_id" in + let+ lib_sym = + fields + ~default: + { + lib_id; + lib_name; + pos = Coord (0, 0); + rot = 0; + unit_nr = 1; + properties = []; + mirror_x = false; + mirror_y = false; + } [ - ("at", pin_at_coord_args >>| (fun (pos, rot) args -> {args with pos; rot})) - ; ("unit", int >>| (fun unit_nr args -> {args with unit_nr})) - ; ("body_style", int >>| (fun _ args -> args)) - ; ("in_bom", atom >>| (fun _ args -> args)) - ; ("on_board", atom >>| (fun _ args -> args)) - ; ("in_pos_files", atom >>| (fun _ args -> args)) - ; ("exclude_from_sim", atom >>| (fun _ args -> args)) - ; ("fields_autoplaced", maybe atom >>| (fun _ args -> args)) - ; ("dnp", atom >>| (fun _ args -> args)) - ; ("mirror", atom >>| (fun axis args -> match axis with - | "x" -> {args with mirror_x=true} - | "y" -> {args with mirror_y=true} - | _ -> failwith "unknown mirror axis")) - ; ("uuid", atom >>| (fun _ args -> args)) - ; ("property", property_args >>| (fun prop args -> {args with properties=prop::args.properties})) - ; ("pin", sch_pin_args >>| (fun _ args -> args)) - ; ("instances", instances_args >>| (fun _ args -> args)) + ( "at", + pin_at_coord_args >>| fun (pos, rot) args -> { args with pos; rot } ); + ("unit", int >>| fun unit_nr args -> { args with unit_nr }); + ("body_style", int >>| fun _ args -> args); + ("in_bom", atom >>| fun _ args -> args); + ("on_board", atom >>| fun _ args -> args); + ("in_pos_files", atom >>| fun _ args -> args); + ("exclude_from_sim", atom >>| fun _ args -> args); + ("fields_autoplaced", maybe atom >>| fun _ args -> args); + ("dnp", atom >>| fun _ args -> args); + ( "mirror", + atom >>| fun axis args -> + match axis with + | "x" -> { args with mirror_x = true } + | "y" -> { args with mirror_y = true } + | _ -> failwith "unknown mirror axis" ); + ("uuid", atom >>| fun _ args -> args); + ( "property", + property_args >>| fun prop args -> + { args with properties = prop :: args.properties } ); + ("pin", sch_pin_args >>| fun _ args -> args); + ("instances", instances_args >>| fun _ args -> args); ] - in lib_sym + in + lib_sym let sch_symbol_expr = field "symbol" sch_symbol_args -;; let parse_list ?(cond = fun _ -> true) form s = let stream = Scanf.Scanning.from_string s in let rec do_parse acc = @@ -823,31 +769,37 @@ let parse_list ?(cond = fun _ -> true) form s = let new_val = Scanf.bscanf stream form (fun x -> x) in if cond new_val then do_parse (new_val :: acc) else acc with - | Scanf.Scan_failure _ -> - acc - | End_of_file -> - acc + | Scanf.Scan_failure _ -> acc + | End_of_file -> acc in do_parse [] -let image_args = fields - ~default: {pos=None; scale=None; data=Some (Buffer.create 1000)} - [ ("at", pin_at_coord_args >>| (fun (apos, _) (args:bitmapContext) -> {args with pos=(Some apos)})) - ; ("uuid", atom >>| (fun _ args -> args)) - ; ("scale", float >>| (fun scale args -> {args with scale=Some scale})) - ; ("data", repeat1_full_list (string ~escaped:false) >>| (fun (strings: string list) args -> - let d = Buffer.create 1000 in - List.iter ~f:(Buffer.add_string d) strings; - match Base64.decode (Buffer.contents d) with - | Ok st -> let databuf = Buffer.create (String.length st) in Buffer.add_string databuf st; {args with data=(Some databuf)} - | Error `Msg msg -> Format.print_string msg; args - )) +let image_args = + fields + ~default:{ pos = None; scale = None; data = Some (Buffer.create 1000) } + [ + ( "at", + pin_at_coord_args >>| fun (apos, _) (args : bitmapContext) -> + { args with pos = Some apos } ); + ("uuid", atom >>| fun _ args -> args); + ("scale", float >>| fun scale args -> { args with scale = Some scale }); + ( "data", + repeat1_full_list (string ~escaped:false) + >>| fun (strings : string list) args -> + let d = Buffer.create 1000 in + List.iter ~f:(Buffer.add_string d) strings; + match Base64.decode (Buffer.contents d) with + | Ok st -> + let databuf = Buffer.create (String.length st) in + Buffer.add_string databuf st; + { args with data = Some databuf } + | Error (`Msg msg) -> + Format.print_string msg; + args ); ] -;; - let sheet_pin_args = - let* name= string ~escaped:false in + let* name = string ~escaped:false in let* port_type = shape_args in let* pos, _angle = pin_at_coord_expr in let* _uuid = maybe uuid_expr in @@ -855,7 +807,7 @@ let sheet_pin_args = let+ _uuid = maybe uuid_expr in let justif = justify_of_effect effects in let sz = fontsize_of_effect effects in - (name, port_type, justif, pos, (Size sz)) + (name, port_type, justif, pos, Size sz) let sheet_pin_expr = field "pin" sheet_pin_args @@ -868,16 +820,16 @@ let sheet_path_instance_expr = field "path" sheet_path_instance_args let sheet_project_args = let* _project_name = string ~escaped:false in - let+ _paths = (repeat1_full_list sheet_path_instance_expr) in + let+ _paths = repeat1_full_list sheet_path_instance_expr in () let sheet_project_instance_expr = field "project" sheet_project_args -let sheet_instances_args = repeat1_full_list sheet_project_instance_expr >>| (fun _ -> 0 ) +let sheet_instances_args = + repeat1_full_list sheet_project_instance_expr >>| fun _ -> 0 let sheet_instances_expr = field "instances" sheet_instances_args - let sheet_args = let* at, _angle = pin_at_coord_expr in let* size = size_expr in @@ -885,28 +837,48 @@ let sheet_args = let* _stroke = maybe stroke_expr in let* _fill = maybe fill_expr in let* _uuid = maybe uuid_expr in - let* properties = repeat_list ~until:(unit_peek ( (sheet_pin_expr >>| (fun _ -> ())) |+> (sheet_instances_expr >>| (fun _ -> ())))) property_expr in - let* hierarchical_pins = repeat_list ~until:(unit_peek sheet_instances_expr) sheet_pin_expr in + let* properties = + repeat_list + ~until: + (unit_peek + (sheet_pin_expr + >>| (fun _ -> ()) + |+> (sheet_instances_expr >>| fun _ -> ()))) + property_expr + in + let* hierarchical_pins = + repeat_list ~until:(unit_peek sheet_instances_expr) sheet_pin_expr + in let+ _instances = sheet_instances_expr in (at, size, properties, hierarchical_pins) -;; - let title_block_args = let* title = field "title" (string ~escaped:false) in let* date = field "date" (string ~escaped:false) in let* rev = field "rev" (string ~escaped:false) in let* company = field "company" (string ~escaped:false) in - let+ comments = repeat_full_list (field "comment" (int <*> string ~escaped:false)) in + let+ comments = + repeat_full_list (field "comment" (int <*> string ~escaped:false)) + in (title, date, rev, company, comments) (* V8: all title-block fields are optional *) let title_block_v8_args = - let* title = maybe (field "title" (string ~escaped:false)) >>| Option.value ~default:"" in - let* date = maybe (field "date" (string ~escaped:false)) >>| Option.value ~default:"" in - let* rev = maybe (field "rev" (string ~escaped:false)) >>| Option.value ~default:"" in - let* company = maybe (field "company" (string ~escaped:false)) >>| Option.value ~default:"" in - let+ comments = repeat_full_list (field "comment" (int <*> string ~escaped:false)) in + let* title = + maybe (field "title" (string ~escaped:false)) >>| Option.value ~default:"" + in + let* date = + maybe (field "date" (string ~escaped:false)) >>| Option.value ~default:"" + in + let* rev = + maybe (field "rev" (string ~escaped:false)) >>| Option.value ~default:"" + in + let* company = + maybe (field "company" (string ~escaped:false)) >>| Option.value ~default:"" + in + let+ comments = + repeat_full_list (field "comment" (int <*> string ~escaped:false)) + in (title, date, rev, company, comments) (* V8 sheet instances: path entries may have variant sub-blocks, which we skip *) @@ -925,7 +897,8 @@ let sheet_project_args_v8 = let sheet_project_instance_expr_v8 = field "project" sheet_project_args_v8 -let sheet_instances_args_v8 = repeat1_full_list sheet_project_instance_expr_v8 >>| (fun _ -> 0) +let sheet_instances_args_v8 = + repeat1_full_list sheet_project_instance_expr_v8 >>| fun _ -> 0 let sheet_instances_expr_v8 = field "instances" sheet_instances_args_v8 @@ -933,22 +906,27 @@ let sheet_instances_expr_v8 = field "instances" sheet_instances_args_v8 let sheet_args_v8 = let* at, _angle = pin_at_coord_expr in let* size = size_expr in - let* _excl = maybe (yesno_expr "exclude_from_sim") in - let* _in_bom = maybe (yesno_expr "in_bom") in + let* _excl = maybe (yesno_expr "exclude_from_sim") in + let* _in_bom = maybe (yesno_expr "in_bom") in let* _on_board = maybe (yesno_expr "on_board") in - let* _dnp = maybe (yesno_expr "dnp") in - let* _locked = maybe (yesno_expr "locked") in + let* _dnp = maybe (yesno_expr "dnp") in + let* _locked = maybe (yesno_expr "locked") in let* _fields_autoplaced = maybe (field "fields_autoplaced" skip_all) in let* _stroke = maybe stroke_expr in - let* _fill = maybe fill_expr in - let* _uuid = maybe uuid_expr in + let* _fill = maybe fill_expr in + let* _uuid = maybe uuid_expr in let* properties = repeat_list - ~until:(unit_peek ((sheet_pin_expr >>| (fun _ -> ())) |+> - (sheet_instances_expr_v8 >>| (fun _ -> ())))) - property_expr in + ~until: + (unit_peek + (sheet_pin_expr + >>| (fun _ -> ()) + |+> (sheet_instances_expr_v8 >>| fun _ -> ()))) + property_expr + in let* hierarchical_pins = - repeat_list ~until:(unit_peek sheet_instances_expr_v8) sheet_pin_expr in + repeat_list ~until:(unit_peek sheet_instances_expr_v8) sheet_pin_expr + in let+ _instances = maybe sheet_instances_expr_v8 in (at, size, properties, hierarchical_pins) @@ -960,26 +938,29 @@ let sch_arc_center_radius (Coord (ax, ay)) (Coord (bx, by)) (Coord (cx, cy)) = let ax = float_of_int ax and ay = float_of_int ay in let bx = float_of_int bx and by = float_of_int by in let cx = float_of_int cx and cy = float_of_int cy in - let d = 2.0 *. ((bx -. ax) *. (cy -. by) -. (cx -. bx) *. (by -. ay)) in + let d = 2.0 *. (((bx -. ax) *. (cy -. by)) -. ((cx -. bx) *. (by -. ay))) in if Float.abs d < 1e-3 then None else - let ab2 = bx *. bx +. by *. by -. ax *. ax -. ay *. ay in - let bc2 = cx *. cx +. cy *. cy -. bx *. bx -. by *. by in - let ux = (ab2 *. (cy -. by) -. bc2 *. (by -. ay)) /. d in - let uy = ((bx -. ax) *. bc2 -. (cx -. bx) *. ab2) /. d in - let r = Float.sqrt ((ux -. ax) *. (ux -. ax) +. (uy -. ay) *. (uy -. ay)) in - Some (Coord (Float.to_int (Float.round ux), Float.to_int (Float.round uy)), - Float.to_int (Float.round r)) + let ab2 = (bx *. bx) +. (by *. by) -. (ax *. ax) -. (ay *. ay) in + let bc2 = (cx *. cx) +. (cy *. cy) -. (bx *. bx) -. (by *. by) in + let ux = ((ab2 *. (cy -. by)) -. (bc2 *. (by -. ay))) /. d in + let uy = (((bx -. ax) *. bc2) -. ((cx -. bx) *. ab2)) /. d in + let r = + Float.sqrt (((ux -. ax) *. (ux -. ax)) +. ((uy -. ay) *. (uy -. ay))) + in + Some + ( Coord (Float.to_int (Float.round ux), Float.to_int (Float.round uy)), + Float.to_int (Float.round r) ) (* V8 schematic arc: (start ...) (mid ...) (end ...) — three points on arc *) let sch_arc_args = let* start_pt = start_point_expr in - let* mid_pt = field "mid" coords in - let* end_pt = end_point_expr in - let* _stroke = maybe stroke_expr in - let* _fill = maybe fill_expr in - let* _uuid = maybe uuid_expr in - let+ _locked = maybe (yesno_expr "locked") in + let* mid_pt = field "mid" coords in + let* end_pt = end_point_expr in + let* _stroke = maybe stroke_expr in + let* _fill = maybe fill_expr in + let* _uuid = maybe uuid_expr in + let+ _locked = maybe (yesno_expr "locked") in match sch_arc_center_radius start_pt mid_pt end_pt with | Some (center, radius) -> Some (center, start_pt, end_pt, radius) | None -> None @@ -987,10 +968,12 @@ let sch_arc_args = (* V8 schematic circle: (center x y) (radius r) *) let sch_circle_args = let* center = field "center" coords in - let* radius = field "radius" float >>| (fun r -> Float.to_int (Float.round (r *. 100.0))) in + let* radius = + field "radius" float >>| fun r -> Float.to_int (Float.round (r *. 100.0)) + in let* _stroke = maybe stroke_expr in - let* _fill = maybe fill_expr in - let* _uuid = maybe uuid_expr in + let* _fill = maybe fill_expr in + let* _uuid = maybe uuid_expr in let+ _locked = maybe (yesno_expr "locked") in (center, radius) @@ -1001,56 +984,64 @@ let sch_bezier_sample p0 p1 p2 p3 n = and fy (Coord (_, y)) = float_of_int y in let cubic t = let mt = 1.0 -. t in - let x = mt*.mt*.mt*.(fx p0) +. 3.*.mt*.mt*.t*.(fx p1) - +. 3.*.mt*.t*.t*.(fx p2) +. t*.t*.t*.(fx p3) in - let y = mt*.mt*.mt*.(fy p0) +. 3.*.mt*.mt*.t*.(fy p1) - +. 3.*.mt*.t*.t*.(fy p2) +. t*.t*.t*.(fy p3) in + let x = + (mt *. mt *. mt *. fx p0) + +. (3. *. mt *. mt *. t *. fx p1) + +. (3. *. mt *. t *. t *. fx p2) + +. (t *. t *. t *. fx p3) + in + let y = + (mt *. mt *. mt *. fy p0) + +. (3. *. mt *. mt *. t *. fy p1) + +. (3. *. mt *. t *. t *. fy p2) + +. (t *. t *. t *. fy p3) + in Coord (Float.to_int (Float.round x), Float.to_int (Float.round y)) in List.init ~len:(n + 1) ~f:(fun i -> cubic (float_of_int i /. float_of_int n)) (* V8 schematic bezier: (pts (xy ...) ...) — 4 control points *) let sch_bezier_args = - let* pts = pts_expr in + let* pts = pts_expr in let* _stroke = maybe stroke_expr in - let* _fill = maybe fill_expr in - let* _uuid = maybe uuid_expr in + let* _fill = maybe fill_expr in + let* _uuid = maybe uuid_expr in let+ _locked = maybe (yesno_expr "locked") in match pts with - | [p0; p1; p2; p3] -> sch_bezier_sample p0 p1 p2 p3 16 - | _ -> pts (* fallback: draw the control polygon *) + | [ p0; p1; p2; p3 ] -> sch_bezier_sample p0 p1 p2 p3 16 + | _ -> pts (* fallback: draw the control polygon *) (* V8 text_box position: either (at + size) or legacy (start + end) *) let text_box_position_args = (let* at, _angle = pin_at_coord_expr in - let+ Coord (w, h) = size_expr in - let Coord (x, y) = at in + let+ (Coord (w, h)) = size_expr in + let (Coord (x, y)) = at in (Coord (x, y), Coord (w, h))) |+> - (let* s = start_point_expr in - let+ Coord (xe, ye) = end_point_expr in - let Coord (xs, ys) = s in - (s, Coord (xe - xs, ye - ys))) + let* s = start_point_expr in + let+ (Coord (xe, ye)) = end_point_expr in + let (Coord (xs, ys)) = s in + (s, Coord (xe - xs, ye - ys)) (* V8 schematic text_box *) let sch_text_box_args = - let* text = string ~escaped:false in - let* _excl = maybe (yesno_expr "exclude_from_sim") in + let* text = string ~escaped:false in + let* _excl = maybe (yesno_expr "exclude_from_sim") in let* corner, dim = text_box_position_args in - let* _marg = maybe (field "margins" skip_all) in + let* _marg = maybe (field "margins" skip_all) in let* _stroke = maybe stroke_expr in - let* _fill = maybe fill_expr in + let* _fill = maybe fill_expr in let* effects = maybe effects_expr in - let* _uuid = maybe uuid_expr in + let* _uuid = maybe uuid_expr in let+ _locked = maybe (yesno_expr "locked") in (corner, dim, text, effects) (* V8 rule_area: flags + embedded polyline *) let sch_rule_area_args = - let* _locked = maybe (yesno_expr "locked") in - let* _excl = maybe (yesno_expr "exclude_from_sim") in - let* _in_bom = maybe (yesno_expr "in_bom") in + let* _locked = maybe (yesno_expr "locked") in + let* _excl = maybe (yesno_expr "exclude_from_sim") in + let* _in_bom = maybe (yesno_expr "in_bom") in let* _on_board = maybe (yesno_expr "on_board") in - let* _dnp = maybe (yesno_expr "dnp") in - let+ (_w, pts) = polyline_expr in + let* _dnp = maybe (yesno_expr "dnp") in + let+ _w, pts = polyline_expr in pts diff --git a/kicadsch/test/Non-Isolated AC-DC Power Module.kicad_sch b/kicadsch/test/Non-Isolated AC-DC Power Module.kicad_sch new file mode 100644 index 0000000..1bc3bcf --- /dev/null +++ b/kicadsch/test/Non-Isolated AC-DC Power Module.kicad_sch @@ -0,0 +1,3763 @@ +(kicad_sch + (version 20250114) + (generator "eeschema") + (generator_version "9.0") + (uuid "9bf14956-bc9e-4eca-9ed1-9bc043e56e36") + (paper "A4") + (title_block + (date "2026-01-16") + (company "Uttkarsh_3") + (comment 1 "drawn by Uttkarsh") + ) + (lib_symbols + (symbol "Connector:Screw_Terminal_01x02" + (pin_names + (offset 1.016) + (hide yes) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "J" + (at 0 2.54 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "Screw_Terminal_01x02" + (at 0 -5.08 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Generic screw terminal, single row, 01x02, script generated (kicad-library-utils/schlib/autogen/connector/)" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "screw terminal" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_fp_filters" "TerminalBlock*:*" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "Screw_Terminal_01x02_1_1" + (rectangle + (start -1.27 1.27) + (end 1.27 -3.81) + (stroke + (width 0.254) + (type default) + ) + (fill + (type background) + ) + ) + (polyline + (pts + (xy -0.5334 0.3302) (xy 0.3302 -0.508) + ) + (stroke + (width 0.1524) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -0.5334 -2.2098) (xy 0.3302 -3.048) + ) + (stroke + (width 0.1524) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -0.3556 0.508) (xy 0.508 -0.3302) + ) + (stroke + (width 0.1524) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -0.3556 -2.032) (xy 0.508 -2.8702) + ) + (stroke + (width 0.1524) + (type default) + ) + (fill + (type none) + ) + ) + (circle + (center 0 0) + (radius 0.635) + (stroke + (width 0.1524) + (type default) + ) + (fill + (type none) + ) + ) + (circle + (center 0 -2.54) + (radius 0.635) + (stroke + (width 0.1524) + (type default) + ) + (fill + (type none) + ) + ) + (pin passive line + (at -5.08 0 0) + (length 3.81) + (name "Pin_1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin passive line + (at -5.08 -2.54 0) + (length 3.81) + (name "Pin_2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "Device:C" + (pin_numbers + (hide yes) + ) + (pin_names + (offset 0.254) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "C" + (at 0.635 2.54 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "C" + (at 0.635 -2.54 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "" + (at 0.9652 -3.81 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Unpolarized capacitor" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "cap capacitor" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_fp_filters" "C_*" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "C_0_1" + (polyline + (pts + (xy -2.032 0.762) (xy 2.032 0.762) + ) + (stroke + (width 0.508) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -2.032 -0.762) (xy 2.032 -0.762) + ) + (stroke + (width 0.508) + (type default) + ) + (fill + (type none) + ) + ) + ) + (symbol "C_1_1" + (pin passive line + (at 0 3.81 270) + (length 2.794) + (name "~" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin passive line + (at 0 -3.81 90) + (length 2.794) + (name "~" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "Device:C_Polarized_US" + (pin_numbers + (hide yes) + ) + (pin_names + (offset 0.254) + (hide yes) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "C" + (at 0.635 2.54 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "C_Polarized_US" + (at 0.635 -2.54 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Polarized capacitor, US symbol" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "cap capacitor" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_fp_filters" "CP_*" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "C_Polarized_US_0_1" + (polyline + (pts + (xy -2.032 0.762) (xy 2.032 0.762) + ) + (stroke + (width 0.508) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -1.778 2.286) (xy -0.762 2.286) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -1.27 1.778) (xy -1.27 2.794) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + (arc + (start -2.032 -1.27) + (mid 0 -0.5572) + (end 2.032 -1.27) + (stroke + (width 0.508) + (type default) + ) + (fill + (type none) + ) + ) + ) + (symbol "C_Polarized_US_1_1" + (pin passive line + (at 0 3.81 270) + (length 2.794) + (name "~" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin passive line + (at 0 -3.81 90) + (length 3.302) + (name "~" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "Device:D_Zener" + (pin_numbers + (hide yes) + ) + (pin_names + (offset 1.016) + (hide yes) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "D" + (at 0 2.54 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "D_Zener" + (at 0 -2.54 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Zener diode" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "diode" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_fp_filters" "TO-???* *_Diode_* *SingleDiode* D_*" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "D_Zener_0_1" + (polyline + (pts + (xy -1.27 -1.27) (xy -1.27 1.27) (xy -0.762 1.27) + ) + (stroke + (width 0.254) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy 1.27 0) (xy -1.27 0) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy 1.27 -1.27) (xy 1.27 1.27) (xy -1.27 0) (xy 1.27 -1.27) + ) + (stroke + (width 0.254) + (type default) + ) + (fill + (type none) + ) + ) + ) + (symbol "D_Zener_1_1" + (pin passive line + (at -3.81 0 0) + (length 2.54) + (name "K" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin passive line + (at 3.81 0 180) + (length 2.54) + (name "A" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "Device:LED" + (pin_numbers + (hide yes) + ) + (pin_names + (offset 1.016) + (hide yes) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "D" + (at 0 2.54 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "LED" + (at 0 -2.54 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Light emitting diode" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Pins" "1=K 2=A" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "LED diode" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_fp_filters" "LED* LED_SMD:* LED_THT:*" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "LED_0_1" + (polyline + (pts + (xy -3.048 -0.762) (xy -4.572 -2.286) (xy -3.81 -2.286) (xy -4.572 -2.286) (xy -4.572 -1.524) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -1.778 -0.762) (xy -3.302 -2.286) (xy -2.54 -2.286) (xy -3.302 -2.286) (xy -3.302 -1.524) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -1.27 0) (xy 1.27 0) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy -1.27 -1.27) (xy -1.27 1.27) + ) + (stroke + (width 0.254) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy 1.27 -1.27) (xy 1.27 1.27) (xy -1.27 0) (xy 1.27 -1.27) + ) + (stroke + (width 0.254) + (type default) + ) + (fill + (type none) + ) + ) + ) + (symbol "LED_1_1" + (pin passive line + (at -3.81 0 0) + (length 2.54) + (name "K" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin passive line + (at 3.81 0 180) + (length 2.54) + (name "A" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "Device:R" + (pin_numbers + (hide yes) + ) + (pin_names + (offset 0) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "R" + (at 2.032 0 90) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "R" + (at 0 0 90) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at -1.778 0 90) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Resistor" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "R res resistor" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_fp_filters" "R_*" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "R_0_1" + (rectangle + (start -1.016 -2.54) + (end 1.016 2.54) + (stroke + (width 0.254) + (type default) + ) + (fill + (type none) + ) + ) + ) + (symbol "R_1_1" + (pin passive line + (at 0 3.81 270) + (length 1.27) + (name "~" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin passive line + (at 0 -3.81 90) + (length 1.27) + (name "~" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "Diode:1N4007" + (pin_numbers + (hide yes) + ) + (pin_names + (hide yes) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "D" + (at 0 2.54 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "1N4007" + (at 0 -2.54 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "Diode_THT:D_DO-41_SOD81_P10.16mm_Horizontal" + (at 0 -4.445 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "http://www.vishay.com/docs/88503/1n4001.pdf" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "1000V 1A General Purpose Rectifier Diode, DO-41" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Device" "D" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Pins" "1=K 2=A" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "diode" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_fp_filters" "D*DO?41*" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "1N4007_0_1" + (polyline + (pts + (xy -1.27 1.27) (xy -1.27 -1.27) + ) + (stroke + (width 0.254) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy 1.27 1.27) (xy 1.27 -1.27) (xy -1.27 0) (xy 1.27 1.27) + ) + (stroke + (width 0.254) + (type default) + ) + (fill + (type none) + ) + ) + (polyline + (pts + (xy 1.27 0) (xy -1.27 0) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + ) + (symbol "1N4007_1_1" + (pin passive line + (at -3.81 0 0) + (length 2.54) + (name "K" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin passive line + (at 3.81 0 180) + (length 2.54) + (name "A" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "Regulator_Linear:LM7805_TO220" + (pin_names + (offset 0.254) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "U" + (at -3.81 3.175 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "LM7805_TO220" + (at 0 3.175 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Package_TO_SOT_THT:TO-220-3_Vertical" + (at 0 5.715 0) + (effects + (font + (size 1.27 1.27) + (italic yes) + ) + (hide yes) + ) + ) + (property "Datasheet" "https://www.onsemi.cn/PowerSolutions/document/MC7800-D.PDF" + (at 0 -1.27 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Positive 1A 35V Linear Regulator, Fixed Output 5V, TO-220" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "Voltage Regulator 1A Positive" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_fp_filters" "TO?220*" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "LM7805_TO220_0_1" + (rectangle + (start -5.08 1.905) + (end 5.08 -5.08) + (stroke + (width 0.254) + (type default) + ) + (fill + (type background) + ) + ) + ) + (symbol "LM7805_TO220_1_1" + (pin power_in line + (at -7.62 0 0) + (length 2.54) + (name "VI" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin power_in line + (at 0 -7.62 90) + (length 2.54) + (name "GND" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "2" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + (pin power_out line + (at 7.62 0 180) + (length 2.54) + (name "VO" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "3" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "power:GND" + (power) + (pin_numbers + (hide yes) + ) + (pin_names + (offset 0) + (hide yes) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "#PWR" + (at 0 -6.35 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Value" "GND" + (at 0 -3.81 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Power symbol creates a global label with name \"GND\" , ground" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "global power" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "GND_0_1" + (polyline + (pts + (xy 0 0) (xy 0 -1.27) (xy 1.27 -1.27) (xy 0 -2.54) (xy -1.27 -1.27) (xy 0 -1.27) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + ) + (symbol "GND_1_1" + (pin power_in line + (at 0 0 270) + (length 0) + (name "~" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (embedded_fonts no) + ) + (symbol "power:PWR_FLAG" + (power) + (pin_numbers + (hide yes) + ) + (pin_names + (offset 0) + (hide yes) + ) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (property "Reference" "#FLG" + (at 0 1.905 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Value" "PWR_FLAG" + (at 0 3.81 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Special symbol for telling ERC where power comes from" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "ki_keywords" "flag power" + (at 0 0 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (symbol "PWR_FLAG_0_0" + (pin power_out line + (at 0 0 90) + (length 0) + (name "~" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (number "1" + (effects + (font + (size 1.27 1.27) + ) + ) + ) + ) + ) + (symbol "PWR_FLAG_0_1" + (polyline + (pts + (xy 0 0) (xy 0 1.27) (xy -1.016 1.905) (xy 0 2.54) (xy 1.016 1.905) (xy 0 1.27) + ) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + ) + ) + (embedded_fonts no) + ) + ) + (rectangle + (start 119.38 58.42) + (end 119.38 58.42) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + (uuid 7787ffa9-fe73-49ee-a79d-4b15b2941ae6) + ) + (rectangle + (start 35.306 59.182) + (end 267.97 132.842) + (stroke + (width 0) + (type default) + ) + (fill + (type none) + ) + (uuid cb66d709-f9e5-41b3-bf52-27fecfd48e0c) + ) + (junction + (at 136.144 85.344) + (diameter 0) + (color 0 0 0 0) + (uuid "0343a5f1-bccd-49c1-8edd-4a2a68ab19fc") + ) + (junction + (at 182.626 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "1480460c-178c-4d37-a561-0af837760c2e") + ) + (junction + (at 188.468 85.344) + (diameter 0) + (color 0 0 0 0) + (uuid "17a2a060-be35-4554-ac6b-1b9e5c7115f3") + ) + (junction + (at 143.002 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "22f594b0-1a49-4746-8163-5fdc23594e8a") + ) + (junction + (at 199.644 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "3fcae7d4-8134-463a-93ee-d0eaba8c44d4") + ) + (junction + (at 82.042 98.552) + (diameter 0) + (color 0 0 0 0) + (uuid "45365770-58db-4d4c-80ba-91264a05c37b") + ) + (junction + (at 58.928 96.012) + (diameter 0) + (color 0 0 0 0) + (uuid "4fde5892-1691-48b1-907b-ece3252d50e7") + ) + (junction + (at 136.144 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "5bf08be5-c584-42f8-9cdf-6bf60b6fde4b") + ) + (junction + (at 214.122 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "6d0df9bc-a458-463f-84f2-9d18c1f38bd5") + ) + (junction + (at 99.314 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "88e118e5-82ee-4389-8fbd-f3ff79916aee") + ) + (junction + (at 82.042 104.648) + (diameter 0) + (color 0 0 0 0) + (uuid "8ad39a98-0a97-4c4e-931a-cd2b522e2fe4") + ) + (junction + (at 150.114 85.344) + (diameter 0) + (color 0 0 0 0) + (uuid "95afa0e0-5a8c-440e-b87f-d85b6c253761") + ) + (junction + (at 165.354 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "9f00542b-ec62-4c2b-bce5-5a3c00ea8032") + ) + (junction + (at 120.142 85.344) + (diameter 0) + (color 0 0 0 0) + (uuid "9fe520ab-b7bb-4c68-87e4-3ec70cc7d871") + ) + (junction + (at 150.114 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "abdea5f7-5852-4dc5-a19b-17911302439f") + ) + (junction + (at 165.354 85.344) + (diameter 0) + (color 0 0 0 0) + (uuid "c1fa13ed-8c16-4fa9-88de-b11eab1ddb12") + ) + (junction + (at 120.142 118.11) + (diameter 0) + (color 0 0 0 0) + (uuid "c6f765dd-821e-49ac-ae4f-5d99563c8d3c") + ) + (junction + (at 76.2 96.012) + (diameter 0) + (color 0 0 0 0) + (uuid "c7ba5a86-e928-49eb-b1cf-b38484ce4166") + ) + (junction + (at 214.122 85.344) + (diameter 0) + (color 0 0 0 0) + (uuid "d043e9ca-dd08-4a58-a14f-09ca54d8e3db") + ) + (junction + (at 99.314 85.344) + (diameter 0) + (color 0 0 0 0) + (uuid "d8f20046-9de8-4272-aaeb-4d6f5c50d3ba") + ) + (junction + (at 182.626 85.344) + (diameter 0) + (color 0 0 0 0) + (uuid "e2fe8d50-8a07-414d-b182-770e444c0e93") + ) + (wire + (pts + (xy 150.114 85.344) (xy 165.354 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "08582e33-bc95-43b7-84f1-b95857c6dfaa") + ) + (wire + (pts + (xy 82.042 118.11) (xy 99.314 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "0bfe082a-d597-4b48-a851-186fb6fc0856") + ) + (wire + (pts + (xy 120.142 118.11) (xy 99.314 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "12625d63-878f-4314-ba73-86b010b93d35") + ) + (wire + (pts + (xy 82.042 89.916) (xy 82.042 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "16387a20-5f91-4db5-8b1d-1a9afc682280") + ) + (wire + (pts + (xy 165.354 85.344) (xy 182.626 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "1c0b14c7-f093-40c4-8713-da4fe7f78692") + ) + (wire + (pts + (xy 136.144 85.344) (xy 136.144 98.044) + ) + (stroke + (width 0) + (type default) + ) + (uuid "1d9104ad-5ae2-4ee4-ad29-4d03af849c01") + ) + (wire + (pts + (xy 58.928 102.108) (xy 58.928 96.012) + ) + (stroke + (width 0) + (type default) + ) + (uuid "21244aeb-40e9-4334-b9af-45cc848939ad") + ) + (wire + (pts + (xy 136.144 118.11) (xy 120.142 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "2b63f35f-9044-4d0a-87da-d6710ed18763") + ) + (wire + (pts + (xy 182.626 96.52) (xy 182.626 103.632) + ) + (stroke + (width 0) + (type default) + ) + (uuid "2f791118-5bb0-4130-b922-4f29bf448a8b") + ) + (wire + (pts + (xy 136.144 85.344) (xy 150.114 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "3000e64f-1c6d-4d59-9d19-46a5d18b1c18") + ) + (wire + (pts + (xy 188.468 85.344) (xy 192.024 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "305d3704-da20-4679-840d-b41e20e7da2a") + ) + (wire + (pts + (xy 71.628 87.376) (xy 76.2 87.376) + ) + (stroke + (width 0) + (type default) + ) + (uuid "310c4582-a580-499a-8e72-86e08a8763a3") + ) + (wire + (pts + (xy 99.314 85.344) (xy 120.142 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "336b4f38-79cc-4de4-b199-ac193a75aca6") + ) + (wire + (pts + (xy 76.2 98.552) (xy 82.042 98.552) + ) + (stroke + (width 0) + (type default) + ) + (uuid "39d567af-3fb9-46d0-866b-39ccf9ef6b6f") + ) + (wire + (pts + (xy 214.122 85.344) (xy 230.886 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "4a110151-8e3c-4708-894b-69ebfada38f6") + ) + (wire + (pts + (xy 165.354 118.11) (xy 165.354 111.76) + ) + (stroke + (width 0) + (type default) + ) + (uuid "4a152aef-45d1-43d3-a8d2-87d918e9f1e9") + ) + (wire + (pts + (xy 199.644 118.11) (xy 214.122 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "4b0bd888-08b6-46ea-8774-d4a39685e11e") + ) + (wire + (pts + (xy 71.882 96.012) (xy 76.2 96.012) + ) + (stroke + (width 0) + (type default) + ) + (uuid "4fed7ba5-2251-44a4-a8e4-6c05eda0ee08") + ) + (wire + (pts + (xy 214.122 106.934) (xy 214.122 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "567e8752-c825-4caa-994e-0153512cc065") + ) + (wire + (pts + (xy 182.626 85.344) (xy 182.626 88.9) + ) + (stroke + (width 0) + (type default) + ) + (uuid "5744af3b-2488-4f58-8fae-02f773596742") + ) + (wire + (pts + (xy 82.042 85.344) (xy 99.314 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "58b8dd12-8525-4a52-a80a-9ec459a9ce09") + ) + (wire + (pts + (xy 150.114 118.11) (xy 165.354 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "6722cdd6-292b-4a53-9384-cb27018fce9b") + ) + (wire + (pts + (xy 76.2 96.012) (xy 76.2 98.552) + ) + (stroke + (width 0) + (type default) + ) + (uuid "706ae9ea-ada1-4ebc-94fd-715ea4b878cd") + ) + (wire + (pts + (xy 136.144 118.11) (xy 143.002 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "718385ba-94dd-4361-aea1-5e60201e45f3") + ) + (wire + (pts + (xy 120.142 105.918) (xy 120.142 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "754a89ef-8061-4d17-b8d3-247c38f4202b") + ) + (wire + (pts + (xy 58.928 87.376) (xy 64.008 87.376) + ) + (stroke + (width 0) + (type default) + ) + (uuid "75d4c58b-9197-4cc3-859f-5bb56d7445f3") + ) + (wire + (pts + (xy 150.114 118.11) (xy 150.114 121.666) + ) + (stroke + (width 0) + (type default) + ) + (uuid "7d4d12ab-1854-4b67-8988-cc40cca7da99") + ) + (wire + (pts + (xy 82.042 97.536) (xy 82.042 98.552) + ) + (stroke + (width 0) + (type default) + ) + (uuid "7e9ea23a-bde4-497d-a403-0f8e78a0dde0") + ) + (wire + (pts + (xy 182.626 118.11) (xy 182.626 111.252) + ) + (stroke + (width 0) + (type default) + ) + (uuid "7eae09f4-26a8-4dd5-ac68-8c21ea65ac9e") + ) + (wire + (pts + (xy 182.626 118.11) (xy 199.644 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "85987c22-5006-4814-bece-bc725243ad6a") + ) + (wire + (pts + (xy 230.886 118.11) (xy 230.886 98.806) + ) + (stroke + (width 0) + (type default) + ) + (uuid "88d15a5d-4337-481d-bc84-ce37069cb98f") + ) + (wire + (pts + (xy 150.114 118.11) (xy 150.114 112.522) + ) + (stroke + (width 0) + (type default) + ) + (uuid "8a36ebd2-b4d6-4a00-9b7b-813c9fce5de3") + ) + (wire + (pts + (xy 165.354 97.028) (xy 165.354 104.14) + ) + (stroke + (width 0) + (type default) + ) + (uuid "8e088c5b-be9c-4aec-9be8-c07a26b407b3") + ) + (wire + (pts + (xy 207.264 85.344) (xy 214.122 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "96101e7a-4beb-4535-92b5-f3b60dac53a6") + ) + (wire + (pts + (xy 55.626 102.108) (xy 58.928 102.108) + ) + (stroke + (width 0) + (type default) + ) + (uuid "99f5b1db-7ec2-44de-bebb-0e89866a1229") + ) + (wire + (pts + (xy 214.122 85.344) (xy 214.122 99.314) + ) + (stroke + (width 0) + (type default) + ) + (uuid "9ec94df1-3d2a-49be-aaaa-89d3dfa7d3a2") + ) + (wire + (pts + (xy 76.2 87.376) (xy 76.2 96.012) + ) + (stroke + (width 0) + (type default) + ) + (uuid "a12249a1-dcfb-4199-8257-144dcba4cc0e") + ) + (wire + (pts + (xy 99.314 85.344) (xy 99.314 89.916) + ) + (stroke + (width 0) + (type default) + ) + (uuid "a1943110-bb26-4f09-833f-7df27b2d252c") + ) + (wire + (pts + (xy 99.314 97.536) (xy 99.314 105.918) + ) + (stroke + (width 0) + (type default) + ) + (uuid "a1edec4a-a571-4bea-bc65-320e50661daa") + ) + (wire + (pts + (xy 165.354 118.11) (xy 182.626 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "a332188b-0872-4994-9db0-23d40287006c") + ) + (wire + (pts + (xy 120.142 85.344) (xy 120.142 98.298) + ) + (stroke + (width 0) + (type default) + ) + (uuid "a5549479-1de0-4241-b291-c8a5cae9ef87") + ) + (wire + (pts + (xy 82.042 104.648) (xy 82.042 106.172) + ) + (stroke + (width 0) + (type default) + ) + (uuid "a85f6a68-517a-4e9c-8cf6-e0b12c304a93") + ) + (wire + (pts + (xy 199.644 92.964) (xy 199.644 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "b0bf1641-376e-4844-ba47-3ead259a18c6") + ) + (wire + (pts + (xy 150.114 89.662) (xy 150.114 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "b7c3da51-106d-4c18-90b7-ad6d1cb3679a") + ) + (wire + (pts + (xy 182.626 85.344) (xy 188.468 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "c206d0a5-8d12-45e8-b878-ff7cfd512f9f") + ) + (wire + (pts + (xy 214.122 118.11) (xy 230.886 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "c710b372-dca8-4584-9345-93d6b32a03d1") + ) + (wire + (pts + (xy 58.928 96.012) (xy 64.262 96.012) + ) + (stroke + (width 0) + (type default) + ) + (uuid "c85d039b-6e83-4d3a-afce-28f9e0043cfc") + ) + (wire + (pts + (xy 136.144 105.664) (xy 136.144 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "d539e264-6002-4660-96a5-274776d5f5cd") + ) + (wire + (pts + (xy 230.886 85.344) (xy 230.886 96.266) + ) + (stroke + (width 0) + (type default) + ) + (uuid "d778a354-2bdf-4d12-aeba-f081f53b5e6f") + ) + (wire + (pts + (xy 82.042 98.552) (xy 82.042 104.648) + ) + (stroke + (width 0) + (type default) + ) + (uuid "d7dc1580-cca1-4232-9f71-39bdc9a82313") + ) + (wire + (pts + (xy 150.114 97.282) (xy 150.114 104.902) + ) + (stroke + (width 0) + (type default) + ) + (uuid "dc86fbc6-502a-44cd-8664-f256f21a3f97") + ) + (wire + (pts + (xy 99.314 118.11) (xy 99.314 113.538) + ) + (stroke + (width 0) + (type default) + ) + (uuid "e0b2a0ef-d7a3-4909-9bb0-bb1ebfae351e") + ) + (wire + (pts + (xy 143.002 118.11) (xy 150.114 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "e42dfc33-f122-43b1-bd63-3d6a36eb8ca2") + ) + (wire + (pts + (xy 55.626 104.648) (xy 82.042 104.648) + ) + (stroke + (width 0) + (type default) + ) + (uuid "ec726a11-a551-4610-b48f-3b54224ea992") + ) + (wire + (pts + (xy 82.042 113.792) (xy 82.042 118.11) + ) + (stroke + (width 0) + (type default) + ) + (uuid "eefea746-07ae-4661-bc43-bb0bb96374f0") + ) + (wire + (pts + (xy 58.928 96.012) (xy 58.928 87.376) + ) + (stroke + (width 0) + (type default) + ) + (uuid "f2336255-fce6-477f-a5dc-40ae6c305d70") + ) + (wire + (pts + (xy 165.354 85.344) (xy 165.354 89.408) + ) + (stroke + (width 0) + (type default) + ) + (uuid "f6115572-8866-4b49-a3b7-b06af5a044b5") + ) + (wire + (pts + (xy 120.142 85.344) (xy 136.144 85.344) + ) + (stroke + (width 0) + (type default) + ) + (uuid "f7280ba8-5049-43ae-a098-2b898ed00614") + ) + (label "Non-Isolated AC-DC Power Supply Design" + (at 92.964 67.056 0) + (effects + (font + (face "Arial Black") + (size 4 4) + (thickness 0.254) + (italic yes) + ) + (justify left bottom) + ) + (uuid "19a0d890-64c4-48fa-85f1-ca7ef2d853b4") + ) + (label "5V" + (at 222.504 85.344 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left bottom) + ) + (uuid "68c1d633-e238-4ed7-a878-515d1c176d0e") + ) + (symbol + (lib_id "Device:D_Zener") + (at 150.114 93.472 270) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "013c939a-eca8-480b-b113-9d7056845681") + (property "Reference" "D6" + (at 156.718 93.472 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "D_Zener" + (at 154.178 93.472 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "Diode_THT:D_A-405_P7.62mm_Horizontal" + (at 150.114 93.472 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 150.114 93.472 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Zener diode" + (at 150.114 93.472 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "18cc44d7-dd89-4ba9-b8e1-0e33ed7ecfd2") + ) + (pin "1" + (uuid "a5692a0c-042f-44eb-b99d-2a27f4b77617") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "D6") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Regulator_Linear:LM7805_TO220") + (at 199.644 85.344 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "025d6cfd-12d8-491d-828c-2ca11bce6b33") + (property "Reference" "U1" + (at 199.644 78.994 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "LM7805_TO220" + (at 199.644 81.534 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "Package_TO_SOT_THT:TO-220-3_Vertical" + (at 199.644 79.629 0) + (effects + (font + (size 1.27 1.27) + (italic yes) + ) + (hide yes) + ) + ) + (property "Datasheet" "https://www.onsemi.cn/PowerSolutions/document/MC7800-D.PDF" + (at 199.644 86.614 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Positive 1A 35V Linear Regulator, Fixed Output 5V, TO-220" + (at 199.644 85.344 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "96695e6b-c066-40f6-9a45-2fb313a5ff6d") + ) + (pin "3" + (uuid "6a239a87-1dd9-45cf-9052-a83789233201") + ) + (pin "2" + (uuid "f71f5d9e-da7a-4b3b-854e-586b0d92acc9") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "U1") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Diode:1N4007") + (at 99.314 109.728 270) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "08b68a54-54d2-46fb-87d2-c53e66287955") + (property "Reference" "D4" + (at 101.6 108.4579 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "1N4007" + (at 101.6 110.9979 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Diode_THT:D_DO-41_SOD81_P10.16mm_Horizontal" + (at 94.869 109.728 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "http://www.vishay.com/docs/88503/1n4001.pdf" + (at 99.314 109.728 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "1000V 1A General Purpose Rectifier Diode, DO-41" + (at 99.314 109.728 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Device" "D" + (at 99.314 109.728 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Pins" "1=K 2=A" + (at 99.314 109.728 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "5afbf364-3aad-4d64-bad7-e5bb9dd07c55") + ) + (pin "2" + (uuid "a7b1a74a-1595-4203-9a1e-f7edc6347757") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "D4") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Connector:Screw_Terminal_01x02") + (at 50.546 104.648 180) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (uuid "0a19a2d1-b4fb-4f5a-8803-6e266e6cf902") + (property "Reference" "J1" + (at 50.546 99.314 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "Screw_Terminal_01x02" + (at 47.752 98.552 90) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "TerminalBlock_4Ucon:TerminalBlock_4Ucon_1x02_P3.50mm_Horizontal" + (at 50.546 104.648 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 50.546 104.648 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Generic screw terminal, single row, 01x02, script generated (kicad-library-utils/schlib/autogen/connector/)" + (at 50.546 104.648 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "81c5d969-030d-4e83-81be-7ca92d89bc78") + ) + (pin "1" + (uuid "ebb48d08-e8c7-4970-8c42-c4a5e592921a") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "J1") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:C_Polarized_US") + (at 214.122 103.124 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (uuid "250d2153-7343-44e6-b8bd-fb08c0e580b6") + (property "Reference" "C3" + (at 217.932 106.426 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "470uf" + (at 217.932 101.854 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Capacitor_THT:CP_Radial_D10.0mm_P3.80mm" + (at 214.122 103.124 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 214.122 103.124 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Polarized capacitor, US symbol" + (at 214.122 103.124 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "8d454948-2fe4-4993-8e0f-ae105548ed97") + ) + (pin "1" + (uuid "0a820a2d-24fb-4c51-8a50-83d1faac56b1") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "C3") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:C_Polarized_US") + (at 136.144 101.854 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (uuid "5478750d-a0b3-4830-90b2-d86f4fc459fa") + (property "Reference" "C2" + (at 137.668 106.68 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "1000uf" + (at 139.446 101.854 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Capacitor_THT:CP_Radial_D10.0mm_P5.00mm" + (at 136.144 101.854 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 136.144 101.854 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Polarized capacitor, US symbol" + (at 136.144 101.854 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "f120cafa-5e5d-41b6-a8c5-9576915bdeda") + ) + (pin "1" + (uuid "7321bc0d-d38d-48f3-8cd9-533d17faf7c8") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "C2") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:R") + (at 150.114 108.712 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "68a298e8-2d28-470b-b527-06984bf1886c") + (property "Reference" "R1" + (at 152.4 107.4419 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "20K" + (at 152.4 109.9819 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Resistor_THT:R_Axial_DIN0207_L6.3mm_D2.5mm_P7.62mm_Horizontal" + (at 148.336 108.712 90) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 150.114 108.712 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Resistor" + (at 150.114 108.712 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "7eca4a87-effc-44c6-801d-c1a50fe54dd0") + ) + (pin "1" + (uuid "46dad987-a4a6-4acc-8f94-b89e5c6de7a7") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "R1") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Diode:1N4007") + (at 82.042 109.982 270) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "6cedd0d9-a3ea-4440-a46f-3416719f62fe") + (property "Reference" "D2" + (at 84.328 108.7119 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "1N4007" + (at 84.328 111.2519 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Diode_THT:D_DO-41_SOD81_P10.16mm_Horizontal" + (at 77.597 109.982 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "http://www.vishay.com/docs/88503/1n4001.pdf" + (at 82.042 109.982 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "1000V 1A General Purpose Rectifier Diode, DO-41" + (at 82.042 109.982 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Device" "D" + (at 82.042 109.982 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Pins" "1=K 2=A" + (at 82.042 109.982 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "a15154af-80cc-4ce2-9634-8026450b6eea") + ) + (pin "2" + (uuid "00e9b33f-ac09-45bb-9027-0e65a772d036") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "D2") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:LED") + (at 182.626 107.442 90) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "6f0bfc43-e72f-4d6f-aaa9-80bc25561379") + (property "Reference" "D7" + (at 186.436 107.7594 90) + (effects + (font + (size 1.27 1.27) + ) + (justify right) + ) + ) + (property "Value" "LED" + (at 186.436 110.2994 90) + (effects + (font + (size 1.27 1.27) + ) + (justify right) + ) + ) + (property "Footprint" "LED_THT:LED_D5.0mm" + (at 182.626 107.442 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 182.626 107.442 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Light emitting diode" + (at 182.626 107.442 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Pins" "1=K 2=A" + (at 182.626 107.442 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "5dd7cb3f-4f27-4ec9-8e76-8d9919e2ae30") + ) + (pin "2" + (uuid "0fd6654e-1fad-448c-ad73-f15f589a2b96") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "D7") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:R") + (at 68.072 96.012 90) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (uuid "74a8233c-712b-4594-88a8-6517028b6f9f") + (property "Reference" "R3" + (at 66.8019 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "1M" + (at 69.3419 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Resistor_THT:R_Axial_DIN0207_L6.3mm_D2.5mm_P7.62mm_Horizontal" + (at 68.072 97.79 90) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 68.072 96.012 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Resistor" + (at 68.072 96.012 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "616f04a8-2f31-46a1-8c0d-1eca673c59a9") + ) + (pin "1" + (uuid "46cc0d5c-b6a4-4fa1-ada4-93ee6c50a1b0") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "R3") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Diode:1N4007") + (at 82.042 93.726 270) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "7bb63fed-da3b-47f0-b1f0-30ba62fad53f") + (property "Reference" "D1" + (at 85.09 92.4559 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "1N4007" + (at 85.09 94.9959 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Diode_THT:D_DO-41_SOD81_P10.16mm_Horizontal" + (at 77.597 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "http://www.vishay.com/docs/88503/1n4001.pdf" + (at 82.042 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "1000V 1A General Purpose Rectifier Diode, DO-41" + (at 82.042 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Device" "D" + (at 82.042 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Pins" "1=K 2=A" + (at 82.042 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "5b3015e6-29f3-46a6-9fe1-b42205c7a64e") + ) + (pin "2" + (uuid "57bf4da4-52e5-4c36-be8f-1604c7855bd7") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "D1") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:D_Zener") + (at 165.354 93.218 270) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "7c00f677-5d48-4729-8b85-fa74fb7b1944") + (property "Reference" "D5" + (at 171.958 93.218 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Value" "D_Zener" + (at 169.418 93.218 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "Diode_THT:D_A-405_P7.62mm_Horizontal" + (at 165.354 93.218 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 165.354 93.218 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Zener diode" + (at 165.354 93.218 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "ced852e8-056c-4e17-a20f-88278d4a0893") + ) + (pin "1" + (uuid "86872018-daa4-4a87-842d-56eea5070832") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "D5") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Diode:1N4007") + (at 99.314 93.726 270) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "80f45329-914e-48bd-bb1b-6b566e095ebb") + (property "Reference" "D3" + (at 101.6 92.4559 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "1N4007" + (at 101.6 94.9959 90) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Diode_THT:D_DO-41_SOD81_P10.16mm_Horizontal" + (at 94.869 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "http://www.vishay.com/docs/88503/1n4001.pdf" + (at 99.314 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "1000V 1A General Purpose Rectifier Diode, DO-41" + (at 99.314 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Device" "D" + (at 99.314 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Sim.Pins" "1=K 2=A" + (at 99.314 93.726 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "3e547a07-5f0e-41d3-83a0-c057acd7b0b4") + ) + (pin "2" + (uuid "a95e48fe-67da-4f69-b80d-69c8a34964b2") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "D3") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:C") + (at 67.818 87.376 90) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (uuid "8cc05bf3-95ee-47b1-b4e5-4fc1e6051d56") + (property "Reference" "C4" + (at 67.056 80.772 90) + (effects + (font + (size 1.27 1.27) + ) + (justify right) + ) + ) + (property "Value" "225K/2.2uf" + (at 61.976 83.566 90) + (effects + (font + (size 1.27 1.27) + ) + (justify right) + ) + ) + (property "Footprint" "Capacitor_THT:C_Rect_L18.0mm_W6.0mm_P15.00mm_FKS3_FKP3" + (at 71.628 86.4108 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 67.818 87.376 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Unpolarized capacitor" + (at 67.818 87.376 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "484ee6cf-b305-4077-ab03-0df4ce94a0ca") + ) + (pin "2" + (uuid "e4096229-39c2-4c5f-9df0-a1d646c97950") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "C4") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:C") + (at 120.142 102.108 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "8fa6be44-2a91-4bd1-ae78-85453042a72a") + (property "Reference" "C1" + (at 123.19 100.8379 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "0.1uf" + (at 123.19 103.3779 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Capacitor_THT:C_Disc_D4.7mm_W2.5mm_P5.00mm" + (at 121.1072 105.918 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 120.142 102.108 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Unpolarized capacitor" + (at 120.142 102.108 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "008dd77b-ca54-427a-b224-4d53c1e34d3b") + ) + (pin "2" + (uuid "cec4cf47-3893-4d5c-b446-42779b9cac02") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "C1") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Connector:Screw_Terminal_01x02") + (at 235.966 96.266 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "9a5a3ced-fb28-4b24-9a31-20857f04a00f") + (property "Reference" "J2" + (at 238.506 96.2659 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "Screw_Terminal_01x02" + (at 238.506 98.8059 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "TerminalBlock_4Ucon:TerminalBlock_4Ucon_1x02_P3.50mm_Horizontal" + (at 235.966 96.266 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 235.966 96.266 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Generic screw terminal, single row, 01x02, script generated (kicad-library-utils/schlib/autogen/connector/)" + (at 235.966 96.266 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "1da1ff7a-9371-4814-a0ff-0e38bff7568e") + ) + (pin "1" + (uuid "35d33391-9199-4f04-8a6d-dcd159e778c2") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "J2") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "power:GND") + (at 150.114 121.666 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "9d8974c3-5a63-4abe-9667-938ec84bf4d5") + (property "Reference" "#PWR01" + (at 150.114 128.016 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Value" "GND" + (at 150.114 126.492 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at 150.114 121.666 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "" + (at 150.114 121.666 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Power symbol creates a global label with name \"GND\" , ground" + (at 150.114 121.666 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "74345e8f-eb2e-40ce-828f-2497e0211bcb") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "#PWR01") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:R") + (at 182.626 92.71 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "b3afeadd-432a-415a-96f1-f258fafd15e0") + (property "Reference" "R4" + (at 185.42 91.4399 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "2.2K" + (at 185.42 93.9799 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Resistor_THT:R_Axial_DIN0207_L6.3mm_D2.5mm_P7.62mm_Horizontal" + (at 180.848 92.71 90) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 182.626 92.71 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Resistor" + (at 182.626 92.71 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "c79e64de-a4a3-4013-bd4e-9e137ad0804e") + ) + (pin "1" + (uuid "10984f86-5a74-46a6-9b54-a80256cae6cc") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "R4") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "power:PWR_FLAG") + (at 188.468 85.344 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "b8c79bec-e565-44f8-a29d-0616c078ab47") + (property "Reference" "#FLG01" + (at 188.468 83.439 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Value" "PWR_FLAG" + (at 188.468 80.772 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at 188.468 85.344 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 188.468 85.344 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Special symbol for telling ERC where power comes from" + (at 188.468 85.344 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "4c4aba34-f581-414f-9a93-5f6f15d3d653") + ) + (instances + (project "" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "#FLG01") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "power:PWR_FLAG") + (at 143.002 118.11 180) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "d38fd98a-768a-4c17-ada6-e14636565581") + (property "Reference" "#FLG02" + (at 143.002 120.015 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Value" "PWR_FLAG" + (at 143.002 122.936 0) + (effects + (font + (size 1.27 1.27) + ) + ) + ) + (property "Footprint" "" + (at 143.002 118.11 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 143.002 118.11 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Special symbol for telling ERC where power comes from" + (at 143.002 118.11 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "1" + (uuid "455c8799-5377-4aef-9248-09637eb35a67") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "#FLG02") + (unit 1) + ) + ) + ) + ) + (symbol + (lib_id "Device:R") + (at 165.354 107.95 0) + (unit 1) + (exclude_from_sim no) + (in_bom yes) + (on_board yes) + (dnp no) + (fields_autoplaced yes) + (uuid "d8c0cef2-2a08-466a-9235-17e94e72ebc4") + (property "Reference" "R2" + (at 167.64 106.6799 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Value" "20K" + (at 167.64 109.2199 0) + (effects + (font + (size 1.27 1.27) + ) + (justify left) + ) + ) + (property "Footprint" "Resistor_THT:R_Axial_DIN0207_L6.3mm_D2.5mm_P7.62mm_Horizontal" + (at 163.576 107.95 90) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Datasheet" "~" + (at 165.354 107.95 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (property "Description" "Resistor" + (at 165.354 107.95 0) + (effects + (font + (size 1.27 1.27) + ) + (hide yes) + ) + ) + (pin "2" + (uuid "cfad8446-c352-4dac-baf0-528ca3c618f4") + ) + (pin "1" + (uuid "a19f556b-9719-47ce-9115-3795fd284a1b") + ) + (instances + (project "Transformerless Power Supply" + (path "/9bf14956-bc9e-4eca-9ed1-9bc043e56e36" + (reference "R2") + (unit 1) + ) + ) + ) + ) + (sheet_instances + (path "/" + (page "1") + ) + ) + (embedded_fonts no) +) diff --git a/kicadsch/test/dune b/kicadsch/test/dune index 82ba610..72b56e1 100644 --- a/kicadsch/test/dune +++ b/kicadsch/test/dune @@ -3,34 +3,16 @@ (modules stubPainter) (wrapped false) (libraries kicadsch) - (flags (:standard -w -27)) - ) + (flags + (:standard -w -27))) (tests - (names test test_sexp_kicad_parser test_kicadsch_v8_parser) - (modules test test_sexp_kicad_parser test_kicadsch_v8_parser) - (libraries - kicadsch - stub_painter_lib - oUnit - csexp - sexp_decode - parsexp - ) - (flags (:standard -w -27 )) - ) - -(test - (name test_real_v8_sch) - (modules test_real_v8_sch) - (libraries - kicadsch - stub_painter_lib - oUnit - csexp - sexp_decode - parsexp - ) - (flags (:standard -w -27 )) - (deps (file "Non-Isolated AC-DC Power Module.kicad_sch")) - ) + (names test test_sexp_kicad_parser test_kicadsch_v8_parser test_real_v8_sch) + (modules + test + test_sexp_kicad_parser + test_kicadsch_v8_parser + test_real_v8_sch) + (libraries kicadsch ounit2 sexp_decode stub_painter_lib) + (flags + (:standard -w -27))) diff --git a/kicadsch/test/stubPainter.ml b/kicadsch/test/stubPainter.ml index 196fd06..30f547c 100644 --- a/kicadsch/test/stubPainter.ml +++ b/kicadsch/test/stubPainter.ml @@ -4,11 +4,11 @@ open Kicadsch.Sigs type t = string list let string_of_justification = function - | J_left -> "J_left" - | J_right -> "J_right" + | J_left -> "J_left" + | J_right -> "J_right" | J_center -> "J_center" | J_bottom -> "J_bottom" - | J_top -> "J_top" + | J_top -> "J_top" let string_of_style = function | Bold -> "Bold" @@ -28,33 +28,43 @@ let string_of_kolor = function | `Blue -> "Blue" | `Brown -> "Brown" -let paint_text ?(kolor=`Black) t (o:orientation) (Coord (x,y)) (Size size) justif styl c = - (Printf.sprintf "Text %s %s %s %d %d %d %s %s" (string_of_kolor kolor) t (string_of_orientation o) x y size (string_of_justification justif) (string_of_style styl) ):: c +let paint_text ?(kolor = `Black) t (o : orientation) (Coord (x, y)) (Size size) + justif styl c = + Printf.sprintf "Text %s %s %s %d %d %d %s %s" (string_of_kolor kolor) t + (string_of_orientation o) x y size + (string_of_justification justif) + (string_of_style styl) + :: c -let paint_line ?(kolor=`NoColor) ?(width=Size 1) (Coord (x1, y1)) (Coord (x2, y2)) c = - (Printf.sprintf "Line %d %d - %d %d" x1 y1 x2 y2) :: c +let paint_line ?(kolor = `NoColor) ?(width = Size 1) (Coord (x1, y1)) + (Coord (x2, y2)) c = + Printf.sprintf "Line %d %d - %d %d" x1 y1 x2 y2 :: c -let paint_rect ?(kolor=`NoColor) ?(fill=`NoColor) (Coord(x, y)) (Coord (dim_x, dim_y)) c = - (Printf.sprintf "Rect %d %d %d %d" x y dim_x dim_y) :: c +let paint_rect ?(kolor = `NoColor) ?(fill = `NoColor) (Coord (x, y)) + (Coord (dim_x, dim_y)) c = + Printf.sprintf "Rect %d %d %d %d" x y dim_x dim_y :: c -let paint_circle ?(kolor=`NoColor) ?(fill=`NoColor) (Coord(x, y)) radius c = - (Printf.sprintf "Circle %d %d %d" x y radius) :: c +let paint_circle ?(kolor = `NoColor) ?(fill = `NoColor) (Coord (x, y)) radius c + = + Printf.sprintf "Circle %d %d %d" x y radius :: c -let paint_ellipse ?(kolor=`NoColor) ?(fill=`NoColor) (Coord(x, y)) major_radius minor_radius rotation_angle c = - (Printf.sprintf "Ellipse %d %d %d %d %d" x y major_radius minor_radius rotation_angle) :: c +let paint_ellipse ?(kolor = `NoColor) ?(fill = `NoColor) (Coord (x, y)) + major_radius minor_radius rotation_angle c = + Printf.sprintf "Ellipse %d %d %d %d %d" x y major_radius minor_radius + rotation_angle + :: c -let paint_ellipse_arc ?(kolor=`NoColor) ?(fill=`NoColor) (Coord(x, y)) major_radius minor_radius rotation_angle start_angle end_angle c = - (Printf.sprintf "EllipseArc %d %d %d %d %d %d %d" x y major_radius minor_radius rotation_angle start_angle end_angle) :: c +let paint_ellipse_arc ?(kolor = `NoColor) ?(fill = `NoColor) (Coord (x, y)) + major_radius minor_radius rotation_angle start_angle end_angle c = + Printf.sprintf "EllipseArc %d %d %d %d %d %d %d" x y major_radius minor_radius + rotation_angle start_angle end_angle + :: c -let paint_arc ?(kolor=`NoColor) ?(fill=`NoColor) - (Coord(cx, cy)) (Coord(sx, sy)) (Coord(ex, ey)) r c = - (Printf.sprintf "Arc %d %d %d %d %d %d %d" cx cy sx sy ex ey r) :: c +let paint_arc ?(kolor = `NoColor) ?(fill = `NoColor) (Coord (cx, cy)) + (Coord (sx, sy)) (Coord (ex, ey)) r c = + Printf.sprintf "Arc %d %d %d %d %d %d %d" cx cy sx sy ex ey r :: c -let paint_image co s b c = - c +let paint_image co s b c = c let get_context () = [] - -let set_canevas_size _ _ c = - c - +let set_canevas_size _ _ c = c let write c = c diff --git a/kicadsch/test/test.ml b/kicadsch/test/test.ml index 7f8a7bb..2ad5a7a 100644 --- a/kicadsch/test/test.ml +++ b/kicadsch/test/test.ml @@ -1,13 +1,15 @@ open OUnit open StdLabels +module MUT = Kicadsch.V5.MakeSchPainter (StubPainter) -module MUT = Kicadsch.V5.MakeSchPainter(StubPainter) -let initial_sheet = {|EESchema Schematic File Version 4 +let initial_sheet = + {|EESchema Schematic File Version 4 EELAYER 26 0 EELAYER END |} -let initial_lib ={|DEF C C 0 10 N Y 1 F N +let initial_lib = + {|DEF C C 0 10 N Y 1 F N F0 "C" 25 100 50 H V L CNN F1 "C" 25 -100 50 H V L CNN F2 "" 38 -150 50 H I C CNN @@ -21,10 +23,8 @@ ENDDEF |} let init () = - let lib_lines = MUT.add_lib initial_lib (MUT.initial_context No_Rev) in + let lib_lines = MUT.add_lib initial_lib (MUT.initial_context No_Rev) in MUT.parse_sheet lib_lines initial_sheet -;; - let test_printable_F_line () = let u = @@ -41,13 +41,15 @@ F 3 "~" H 3750 2500 50 0001 C CNN 1 0 0 -1 $EndComp $EndSCHEMATC|} - |> MUT.parse_sheet (init ()) in + |> MUT.parse_sheet (init ()) + in let output = StubPainter.write (MUT.output_context u) in match output with | [] -> assert_failure "Field should have been printed" - | [v] -> assert_equal v "Text Black C Orient_H 3865 2545 50 J_left NoStyle" - | u::v::w ->List.iter ~f:(Printf.printf "%s\n") output;assert_failure "Only one line should be printed\n" -;; + | [ v ] -> assert_equal v "Text Black C Orient_H 3865 2545 50 J_left NoStyle" + | u :: v :: w -> + List.iter ~f:(Printf.printf "%s\n") output; + assert_failure "Only one line should be printed\n" let test_escaped_F_line () = let u = @@ -64,13 +66,14 @@ F 3 "~" H 3750 2500 50 0001 C CNN 1 0 0 -1 $EndComp $EndSCHEMATC|} - |> MUT.parse_sheet (init ()) in + |> MUT.parse_sheet (init ()) + in let output = StubPainter.write (MUT.output_context u) in match output with | [] -> assert_failure "Field should have been printed" - | [v] -> assert_equal v "Text Black C\" 3 Orient_H 3865 2545 50 J_left NoStyle" - | u::v::w -> assert_failure "Only one line should be printed" -;; + | [ v ] -> + assert_equal v "Text Black C\" 3 Orient_H 3865 2545 50 J_left NoStyle" + | u :: v :: w -> assert_failure "Only one line should be printed" let test_zero_length_lines () = let u = @@ -87,97 +90,122 @@ F 3 "~" H 3750 2500 50 0001 C CNN 1 0 0 -1 $EndComp $EndSCHEMATC|} - |> MUT.parse_sheet (init ()) in + |> MUT.parse_sheet (init ()) + in let output = StubPainter.write (MUT.output_context u) in match output with | [] -> () | _ -> assert_failure "Field should not have been printed" -;; let match_wire_line () = - let v = {|Wire Wire Line + let v = + {|Wire Wire Line 5500 1700 5500 2200 -|} - |> MUT.parse_sheet (init ()) in +|} |> MUT.parse_sheet (init ()) + in match StubPainter.write (MUT.output_context v) with - | [v] -> () + | [ v ] -> () | _ -> assert_failure "Wire line should have matched" -;; let segment_horizontal_wire wire_type () = let u = - Printf.sprintf {|Wire %s Line + Printf.sprintf + {|Wire %s Line 5500 1700 5500 2200 Connection ~ 5500 1800 Entry Wire Line 5500 2000 5550 2050 Entry Bus Line 5500 2100 5550 2150 5550 -|} wire_type - |> MUT.parse_sheet (init ()) in +|} + wire_type + |> MUT.parse_sheet (init ()) + in let output = StubPainter.write (MUT.output_context u) in - assert_bool "Connection segment present" (List.mem "Line 5500 1700 - 5500 1800" ~set:output); - assert_bool "Entry wire segment present" (List.mem "Line 5500 1800 - 5500 2000" ~set:output); - assert_bool "Entry bus segment present" (List.mem "Line 5500 2000 - 5500 2100" ~set:output); - assert_bool "Fourth segment present" (List.mem "Line 5500 2100 - 5500 2200" ~set:output) + assert_bool "Connection segment present" + (List.mem "Line 5500 1700 - 5500 1800" ~set:output); + assert_bool "Entry wire segment present" + (List.mem "Line 5500 1800 - 5500 2000" ~set:output); + assert_bool "Entry bus segment present" + (List.mem "Line 5500 2000 - 5500 2100" ~set:output); + assert_bool "Fourth segment present" + (List.mem "Line 5500 2100 - 5500 2200" ~set:output) let segment_inverse_horizontal_wire wire_type () = let u = - Printf.sprintf {|Wire %s Line + Printf.sprintf + {|Wire %s Line 5500 2200 5500 1700 Connection ~ 5500 1800 Entry Wire Line 5500 2000 5550 2050 Entry Bus Line 5500 2100 5550 2150 -|} wire_type - |> MUT.parse_sheet (init ()) in +|} + wire_type + |> MUT.parse_sheet (init ()) + in let output = StubPainter.write (MUT.output_context u) in - assert_bool "Connection segment present" (List.mem "Line 5500 1700 - 5500 1800" ~set:output); - assert_bool "Entry wire segment present" (List.mem "Line 5500 1800 - 5500 2000" ~set:output); - assert_bool "Entry bus segment present" (List.mem "Line 5500 2000 - 5500 2100" ~set:output); - assert_bool "Fourth segment present" (List.mem "Line 5500 2100 - 5500 2200" ~set:output) -;; + assert_bool "Connection segment present" + (List.mem "Line 5500 1700 - 5500 1800" ~set:output); + assert_bool "Entry wire segment present" + (List.mem "Line 5500 1800 - 5500 2000" ~set:output); + assert_bool "Entry bus segment present" + (List.mem "Line 5500 2000 - 5500 2100" ~set:output); + assert_bool "Fourth segment present" + (List.mem "Line 5500 2100 - 5500 2200" ~set:output) let segment_vertical_wire wire_type () = let u = - Printf.sprintf {|Wire %s Line + Printf.sprintf + {|Wire %s Line 1700 5500 2200 5500 Connection ~ 1800 5500 Entry Wire Line 2000 5500 2050 5550 Entry Bus Line 2100 5500 2150 5550 -|} wire_type - |> MUT.parse_sheet (init ()) in +|} + wire_type + |> MUT.parse_sheet (init ()) + in let output = StubPainter.write (MUT.output_context u) in - assert_bool "Connection segment present" (List.mem "Line 1700 5500 - 1800 5500" ~set:output); - assert_bool "Entry wire segment present" (List.mem "Line 1800 5500 - 2000 5500" ~set:output); - assert_bool "Entry bus segment present" (List.mem "Line 2000 5500 - 2100 5500" ~set:output); - assert_bool "Fourth segment present" (List.mem "Line 2100 5500 - 2200 5500" ~set:output) -;; + assert_bool "Connection segment present" + (List.mem "Line 1700 5500 - 1800 5500" ~set:output); + assert_bool "Entry wire segment present" + (List.mem "Line 1800 5500 - 2000 5500" ~set:output); + assert_bool "Entry bus segment present" + (List.mem "Line 2000 5500 - 2100 5500" ~set:output); + assert_bool "Fourth segment present" + (List.mem "Line 2100 5500 - 2200 5500" ~set:output) let segment_inverse_vertical_wire wire_type () = let u = - Printf.sprintf {|Wire %s Line + Printf.sprintf + {|Wire %s Line 2200 5500 1700 5500 Connection ~ 1800 5500 Entry Wire Line 2000 5500 2050 5550 Entry Bus Line 2100 5500 2150 5550 -|} wire_type - |> MUT.parse_sheet (init ()) in +|} + wire_type + |> MUT.parse_sheet (init ()) + in let output = StubPainter.write (MUT.output_context u) in - assert_bool "Connection segment present" (List.mem "Line 1700 5500 - 1800 5500" ~set:output); - assert_bool "Entry wire segment present" (List.mem "Line 1800 5500 - 2000 5500" ~set:output); - assert_bool "Entry bus segment present" (List.mem "Line 2000 5500 - 2100 5500" ~set:output); - assert_bool "Fourth segment present" (List.mem "Line 2100 5500 - 2200 5500" ~set:output) -;; + assert_bool "Connection segment present" + (List.mem "Line 1700 5500 - 1800 5500" ~set:output); + assert_bool "Entry wire segment present" + (List.mem "Line 1800 5500 - 2000 5500" ~set:output); + assert_bool "Entry bus segment present" + (List.mem "Line 2000 5500 - 2100 5500" ~set:output); + assert_bool "Fourth segment present" + (List.mem "Line 2100 5500 - 2200 5500" ~set:output) let segment_vertical_wire_test () = let u = - {|Wire Wire Line + {|Wire Wire Line 6000 1150 6000 2750 Wire Wire Line 6000 1350 6000 1350 @@ -186,29 +214,39 @@ Connection ~ 6000 2050 Connection ~ 6000 1250 Connection ~ 6000 1150 |} - |> MUT.parse_sheet (init ()) in + |> MUT.parse_sheet (init ()) + in let output = StubPainter.write (MUT.output_context u) in - assert_bool "Wire 1150 - 1250" (List.mem "Line 6000 1150 - 6000 1250" ~set:output) - ; assert_bool "Wire 1250 - 1350" (List.mem "Line 6000 1250 - 6000 1350" ~set:output) - ; assert_bool "Wire 1350 - 2050" (List.mem "Line 6000 1350 - 6000 2050" ~set:output) - ; assert_bool "Wire 2050 - 2750" (List.mem "Line 6000 2050 - 6000 2750" ~set:output) - ; assert_bool "no Wire 1150 - 1150" (not(List.mem "Line 6000 1150 - 6000 1150" ~set:output)) -;; + assert_bool "Wire 1150 - 1250" + (List.mem "Line 6000 1150 - 6000 1250" ~set:output); + assert_bool "Wire 1250 - 1350" + (List.mem "Line 6000 1250 - 6000 1350" ~set:output); + assert_bool "Wire 1350 - 2050" + (List.mem "Line 6000 1350 - 6000 2050" ~set:output); + assert_bool "Wire 2050 - 2750" + (List.mem "Line 6000 2050 - 6000 2750" ~set:output); + assert_bool "no Wire 1150 - 1150" + (not (List.mem "Line 6000 1150 - 6000 1150" ~set:output)) + +let suite = + "OUnit for " + >::: [ + "printable F line" >:: test_printable_F_line; + "match wire line" >:: match_wire_line; + "zero length lines" >:: test_zero_length_lines; + "escaped field lines" >:: test_escaped_F_line; + "Segment horizontal wire" >:: segment_horizontal_wire "Wire"; + "Segment inverse horizontal wire" + >:: segment_inverse_horizontal_wire "Wire"; + "Segment vertical wire" >:: segment_vertical_wire "Wire"; + "Segment inverse vertical wire" + >:: segment_inverse_vertical_wire "Wire"; + "Segment horizontal bus" >:: segment_horizontal_wire "Bus"; + "Segment inverse horizontal bus" + >:: segment_inverse_horizontal_wire "Bus"; + "Segment vertical bus" >:: segment_vertical_wire "Bus"; + "Segment inverse vertical bus" >:: segment_inverse_vertical_wire "Bus"; + "Segment vertical test " >:: segment_vertical_wire_test; + ] -let suite = "OUnit for " >::: - [ "printable F line" >:: test_printable_F_line - ; "match wire line" >:: match_wire_line - ; "zero length lines" >:: test_zero_length_lines - ; "escaped field lines" >:: test_escaped_F_line - ; "Segment horizontal wire" >:: segment_horizontal_wire "Wire" - ; "Segment inverse horizontal wire" >:: segment_inverse_horizontal_wire "Wire" - ; "Segment vertical wire" >:: segment_vertical_wire "Wire" - ; "Segment inverse vertical wire" >:: segment_inverse_vertical_wire "Wire" - ; "Segment horizontal bus" >:: segment_horizontal_wire "Bus" - ; "Segment inverse horizontal bus" >:: segment_inverse_horizontal_wire "Bus" - ; "Segment vertical bus" >:: segment_vertical_wire "Bus" - ; "Segment inverse vertical bus" >:: segment_inverse_vertical_wire "Bus" - ; "Segment vertical test ">:: segment_vertical_wire_test - ] -let _ = - run_test_tt_main suite +let _ = run_test_tt_main suite diff --git a/kicadsch/test/test_kicadsch_v8_parser.ml b/kicadsch/test/test_kicadsch_v8_parser.ml index 7b748ab..f940db3 100644 --- a/kicadsch/test/test_kicadsch_v8_parser.ml +++ b/kicadsch/test/test_kicadsch_v8_parser.ml @@ -1,12 +1,13 @@ open OUnit open StdLabels - -module MUT = Kicadsch.V8.MakeSchPainter(StubPainter) +module MUT = Kicadsch.V8.MakeSchPainter (StubPainter) (* ── Helpers ─────────────────────────────────────────────────────────── *) (** Wrap a fragment in a minimal V8 schematic header (with A4 paper). *) -let wrap body = Printf.sprintf {|(kicad_sch +let wrap body = + Printf.sprintf + {|(kicad_sch (version 20250114) (generator "eeschema") (generator_version "9.0") @@ -14,10 +15,10 @@ let wrap body = Printf.sprintf {|(kicad_sch (paper "A4") (lib_symbols) %s -)|} body +)|} + body let init () = MUT.initial_context No_Rev - let parse body = MUT.parse_sheet (init ()) (wrap body) let output body = StubPainter.write (MUT.output_context (parse body)) @@ -31,28 +32,31 @@ let ends_with ~suffix s = slen >= n && String.sub s ~pos:(slen - n) ~len:n = suffix (** Keep only entries that start with the given tag word. *) -let filter_tag tag out = - List.filter ~f:(starts_with ~prefix:(tag ^ " ")) out +let filter_tag tag out = List.filter ~f:(starts_with ~prefix:(tag ^ " ")) out -let lines_of = filter_tag "Line" +let lines_of = filter_tag "Line" let circles_of = filter_tag "Circle" let ellipses_of = filter_tag "Ellipse" let ellipses_arc_of = filter_tag "EllipseArc" -let arcs_of = filter_tag "Arc" -let rects_of = filter_tag "Rect" -let texts_of = filter_tag "Text" +let arcs_of = filter_tag "Arc" +let rects_of = filter_tag "Rect" +let texts_of = filter_tag "Text" (* ── Smoke tests ─────────────────────────────────────────────────────── *) let test_minimal_parses () = - let _ = MUT.parse_sheet (init ()) {|(kicad_sch + let _ = + MUT.parse_sheet (init ()) + {|(kicad_sch (version 20250114) (generator "eeschema") (generator_version "9.0") (uuid "11111111-1111-1111-1111-111111111111") (paper "A4") (lib_symbols) -)|} in () +)|} + in + () let test_no_title_block_parses () = (* title_block with no children: all fields default to "" — no text drawn *) @@ -62,9 +66,12 @@ let test_no_title_block_parses () = let test_partial_title_block_parses () = (* only title and rev are present *) let out = output {|(title_block (title "My Board") (rev "B"))|} in - let titles = List.filter ~f:(fun s -> - String.length s > 12 && - String.sub s ~pos:0 ~len:12 = "Text Black T") (texts_of out) in + let titles = + List.filter + ~f:(fun s -> + String.length s > 12 && String.sub s ~pos:0 ~len:12 = "Text Black T") + (texts_of out) + in assert_bool "Title text appears" (titles <> []) (* ── Wire ────────────────────────────────────────────────────────────── *) @@ -73,11 +80,14 @@ let test_partial_title_block_parses () = Internal units: wx_size x = int_of_float (x *. 100.) So (xy 0 0) → Coord(0,0) and (xy 10 0) → Coord(1000,0). *) let test_wire_value () = - let out = output {|(wire + let out = + output + {|(wire (pts (xy 0 0) (xy 10 0)) (stroke (width 0) (type default)) (uuid "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaaa") - )|} in + )|} + in assert_bool "Wire segment Line 0 0 - 1000 0" (List.mem "Line 0 0 - 1000 0" ~set:(lines_of out)) @@ -93,25 +103,31 @@ let test_wire_value () = ux = 100 uy = 200 r = 500 Expected: "Arc 100 200 600 200 -400 200 500" *) let test_arc_value () = - let out = output {|(arc + let out = + output + {|(arc (start 6 2) (mid 1 7) (end -4 2) (stroke (width 0) (type default)) (uuid "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaab") - )|} in + )|} + in assert_bool "Arc drawn with correct center/start/end/radius" (List.mem "Arc 100 200 600 200 -400 200 500" ~set:(arcs_of out)) (* Collinear arc points → degenerate, center computation returns None → no arc drawn *) let test_arc_collinear_no_output () = - let out = output {|(arc + let out = + output + {|(arc (start 0 0) (mid 5 0) (end 10 0) (stroke (width 0) (type default)) (uuid "aaaaaaaa-aaaa-aaaa-aaaa-aaaaaaaaaaac") - )|} in + )|} + in assert_equal ~msg:"Degenerate arc produces no Arc entry" [] (arcs_of out) (* ── Circle ──────────────────────────────────────────────────────────── *) @@ -120,12 +136,15 @@ let test_arc_collinear_no_output () = Internal: center=Coord(100,200) radius = round(3.0*100) = 300 Expected: "Circle 100 200 300" *) let test_circle_value () = - let out = output {|(circle + let out = + output + {|(circle (center 1 2) (radius 3) (stroke (width 0) (type default)) (uuid "bbbbbbbb-bbbb-bbbb-bbbb-bbbbbbbbbbbb") - )|} in + )|} + in assert_bool "Circle drawn with correct center and radius" (List.mem "Circle 100 200 300" ~set:(circles_of out)) @@ -140,20 +159,26 @@ let test_circle_value () = First segment: "Line 0 0 - " starts with "Line 0 0 -" Last segment: "Line - 1000 0" ends with "- 1000 0" *) let test_bezier_16_segments () = - let out = output {|(bezier + let out = + output + {|(bezier (pts (xy 0 0) (xy 0 10) (xy 10 10) (xy 10 0)) (stroke (width 0) (type default)) (uuid "cccccccc-cccc-cccc-cccc-cccccccccccc") - )|} in + )|} + in let segs = lines_of out in assert_equal ~msg:"Bézier produces 16 line segments" 16 (List.length segs) let test_bezier_starts_at_p0 () = - let out = output {|(bezier + let out = + output + {|(bezier (pts (xy 0 0) (xy 0 10) (xy 10 10) (xy 10 0)) (stroke (width 0) (type default)) (uuid "cccccccc-cccc-cccc-cccc-cccccccccccd") - )|} in + )|} + in let segs = lines_of out in (* last element = first painted = first segment starting at P0=(0,0) *) let first_seg = List.nth segs (List.length segs - 1) in @@ -161,11 +186,14 @@ let test_bezier_starts_at_p0 () = (starts_with ~prefix:"Line 0 0 -" first_seg) let test_bezier_ends_at_p3 () = - let out = output {|(bezier + let out = + output + {|(bezier (pts (xy 0 0) (xy 0 10) (xy 10 10) (xy 10 0)) (stroke (width 0) (type default)) (uuid "cccccccc-cccc-cccc-cccc-cccccccccccf") - )|} in + )|} + in let segs = lines_of out in (* head = last painted = last segment ending at P3=(1000,0) *) let last_seg = List.hd segs in @@ -182,7 +210,9 @@ let test_bezier_ends_at_p3 () = "Line 1000 1000 - 0 1000" third edge "Line 0 1000 - 0 0" fourth (closing) edge *) let test_rule_area_value () = - let out = output {|(rule_area + let out = + output + {|(rule_area (exclude_from_sim no) (in_bom no) (on_board no) @@ -192,7 +222,8 @@ let test_rule_area_value () = (stroke (width 0) (type default)) (uuid "dddddddd-dddd-dddd-dddd-dddddddddddd") ) - )|} in + )|} + in let segs = lines_of out in assert_bool "First edge (0,0)→(1000,0)" (List.mem "Line 0 0 - 1000 0" ~set:segs); @@ -216,7 +247,9 @@ let test_rule_area_value () = paint_text kolor=Green "Hello" Orient_H Coord(100,200) Size(127) J_left NoStyle → "Text Green Hello Orient_H 100 200 127 J_left NoStyle" *) let test_text_box_at_size_value () = - let out = output {|(text_box "Hello" + let out = + output + {|(text_box "Hello" (exclude_from_sim no) (at 1 2 0) (size 5 3) @@ -224,7 +257,8 @@ let test_text_box_at_size_value () = (fill (type none)) (effects (font (size 1.27 1.27)) (justify left)) (uuid "eeeeeeee-eeee-eeee-eeee-eeeeeeeeeeee") - )|} in + )|} + in assert_bool "Text content matches input string" (List.mem "Text Green Hello Orient_H 100 200 127 J_left NoStyle" ~set:(texts_of out)); @@ -233,7 +267,9 @@ let test_text_box_at_size_value () = (* Legacy start+end form produces the same corner and bottom-right *) let test_text_box_start_end_value () = - let out = output {|(text_box "World" + let out = + output + {|(text_box "World" (exclude_from_sim no) (start 1 2) (end 6 5) @@ -241,7 +277,8 @@ let test_text_box_start_end_value () = (fill (type none)) (effects (font (size 1.27 1.27)) (justify left)) (uuid "eeeeeeee-eeee-eeee-eeee-eeeeeeeeeef0") - )|} in + )|} + in (* start=(1,2)→Coord(100,200) end=(6,5)→Coord(600,500) corner=Coord(100,200) dim=Coord(600-100,500-200)=Coord(500,300) bottom-right = Coord(100+500,200+300) = Coord(600,500) @@ -256,11 +293,14 @@ let test_text_box_start_end_value () = (* label "NET1" at=(0,0) justify=left → drawn as WireLabel (kolor=Red) *) let test_label_value () = - let out = output {|(label "NET1" + let out = + output + {|(label "NET1" (at 0 0 0) (effects (font (size 1.27 1.27)) (justify left)) (uuid "ffffffff-ffff-ffff-ffff-ffffffffffff") - )|} in + )|} + in assert_bool "Label text appears with correct coords and colour" (List.mem "Text Red NET1 Orient_H 0 0 127 J_left NoStyle" ~set:(texts_of out)) @@ -273,11 +313,14 @@ let test_label_value () = rotation_angle=0 → 0 Expected: "Ellipse 10000 10000 5000 3000 0" *) let test_ellipse_value () = - let out = output {|(ellipse + let out = + output + {|(ellipse (center 100 100) (major_radius 50) (minor_radius 30) (rotation_angle 0) (stroke (width 0) (type default)) (uuid "ffffffff-ffff-ffff-ffff-fffffffffffe") - )|} in + )|} + in assert_bool "Ellipse drawn with correct center/radii/angle" (List.mem "Ellipse 10000 10000 5000 3000 0" ~set:(ellipses_of out)) @@ -286,14 +329,18 @@ let test_ellipse_value () = rotation_angle=0, start_angle=0, end_angle=90 Expected: "EllipseArc 10000 10000 5000 3000 0 0 90" *) let test_ellipse_arc_value () = - let out = output {|(ellipse_arc + let out = + output + {|(ellipse_arc (center 100 100) (major_radius 50) (minor_radius 30) (rotation_angle 0) (start_angle 0) (end_angle 90) (stroke (width 0) (type default)) (uuid "ffffffff-ffff-ffff-ffff-fffffffffffd") - )|} in + )|} + in assert_bool "EllipseArc drawn with correct parameters" - (List.mem "EllipseArc 10000 10000 5000 3000 0 0 90" ~set:(ellipses_arc_of out)) + (List.mem "EllipseArc 10000 10000 5000 3000 0 0 90" + ~set:(ellipses_arc_of out)) let test_embedded_fonts_no_output () = let out = output "(embedded_fonts no)" in @@ -306,43 +353,49 @@ let test_net_chain_no_output () = (arcs_of out @ circles_of out @ lines_of out) let test_group_no_output () = - let out = output {|(group "g1" + let out = + output + {|(group "g1" (uuid "ffffffff-ffff-ffff-ffff-fffffffffffc") (members) - )|} in + )|} + in assert_equal ~msg:"group produces no drawn output" [] (arcs_of out @ circles_of out @ lines_of out) (* ── Suite ────────────────────────────────────────────────────────────── *) -let suite = "KiCad V8 schematic parser" >::: - [ "minimal v8 schematic parses" >:: test_minimal_parses - ; "empty title_block produces no text" >:: test_no_title_block_parses - ; "partial title_block renders present fields" >:: test_partial_title_block_parses - (* Wire *) - ; "wire segment: correct coordinates" >:: test_wire_value - (* Arc *) - ; "arc: correct center/start/end/radius" >:: test_arc_value - ; "arc: collinear points produce no output" >:: test_arc_collinear_no_output - (* Circle *) - ; "circle: correct center and radius" >:: test_circle_value - (* Bézier *) - ; "bezier: exactly 16 line segments" >:: test_bezier_16_segments - ; "bezier: first segment starts at P0" >:: test_bezier_starts_at_p0 - ; "bezier: last segment ends at P3" >:: test_bezier_ends_at_p3 - (* Rule area *) - ; "rule_area: all four square edges present" >:: test_rule_area_value - (* Text box *) - ; "text_box (at+size): text and rect values" >:: test_text_box_at_size_value - ; "text_box (start+end): text and rect values" >:: test_text_box_start_end_value - (* Labels *) - ; "label: text value and coordinates" >:: test_label_value - (* Ellipse *) - ; "ellipse: correct center/radii/angle" >:: test_ellipse_value - ; "ellipse_arc: correct parameters" >:: test_ellipse_arc_value - ; "embedded_fonts: no drawn output" >:: test_embedded_fonts_no_output - ; "net_chain: no drawn output" >:: test_net_chain_no_output - ; "group: no drawn output" >:: test_group_no_output - ] +let suite = + "KiCad V8 schematic parser" + >::: [ + "minimal v8 schematic parses" >:: test_minimal_parses; + "empty title_block produces no text" >:: test_no_title_block_parses; + "partial title_block renders present fields" + >:: test_partial_title_block_parses + (* Wire *); + "wire segment: correct coordinates" >:: test_wire_value (* Arc *); + "arc: correct center/start/end/radius" >:: test_arc_value; + "arc: collinear points produce no output" + >:: test_arc_collinear_no_output + (* Circle *); + "circle: correct center and radius" >:: test_circle_value (* Bézier *); + "bezier: exactly 16 line segments" >:: test_bezier_16_segments; + "bezier: first segment starts at P0" >:: test_bezier_starts_at_p0; + "bezier: last segment ends at P3" >:: test_bezier_ends_at_p3 + (* Rule area *); + "rule_area: all four square edges present" >:: test_rule_area_value + (* Text box *); + "text_box (at+size): text and rect values" + >:: test_text_box_at_size_value; + "text_box (start+end): text and rect values" + >:: test_text_box_start_end_value + (* Labels *); + "label: text value and coordinates" >:: test_label_value (* Ellipse *); + "ellipse: correct center/radii/angle" >:: test_ellipse_value; + "ellipse_arc: correct parameters" >:: test_ellipse_arc_value; + "embedded_fonts: no drawn output" >:: test_embedded_fonts_no_output; + "net_chain: no drawn output" >:: test_net_chain_no_output; + "group: no drawn output" >:: test_group_no_output; + ] let _ = run_test_tt_main suite diff --git a/kicadsch/test/test_new_kicad_parser.ml b/kicadsch/test/test_new_kicad_parser.ml index 5365084..77c6f8b 100644 --- a/kicadsch/test/test_new_kicad_parser.ml +++ b/kicadsch/test/test_new_kicad_parser.ml @@ -6,101 +6,138 @@ open Kicadsch.Lib_sigs open Angstrom let create_test parser checker = - fun parse_expr expected_value -> - let t = parse_string ~consume:Consume.All parser parse_expr in - match t with - | Ok res -> checker expected_value res - | Error e -> assert_failure ("not parsed: " ^ e) + fun parse_expr expected_value -> + let t = parse_string ~consume:Consume.All parser parse_expr in + match t with + | Ok res -> checker expected_value res + | Error e -> assert_failure ("not parsed: " ^ e) let test_list single_test test_list = - List.map ~f: (fun (expr, j ) -> (expr >:: (fun _ -> (single_test expr j)))) test_list -;; + List.map ~f:(fun (expr, j) -> expr >:: fun _ -> single_test expr j) test_list let check_string s1 s2 = assert_equal s1 s2 - let test_string = create_test (string_expr "test") check_string -let string_tests = test_list test_string - [ ("(test \"toto\")", "toto") (* standard *) - ; ("(test \"toto\")", "toto") (* white spacLKes in middle *) - ; ("( test \"toto\")", "toto") (* white space at start *) - ; ("(test \"toto\" )", "toto") (* white space at end *) - ; ("(test \"toto\\\"\")", "toto\"") (* escaped string *) +let string_tests = + test_list test_string + [ + ("(test \"toto\")", "toto") (* standard *); + ("(test \"toto\")", "toto") (* white spacLKes in middle *); + ("( test \"toto\")", "toto") (* white space at start *); + ("(test \"toto\" )", "toto") (* white space at end *); + ("(test \"toto\\\"\")", "toto\"") (* escaped string *); ] -;; -let test_int ()= +let test_int () = let t = parse_string ~consume:Consume.All (int_expr "test") "(test 123)" in - match t with - | Ok 123 -> () - | _ -> assert_failure "not parsed" + match t with Ok 123 -> () | _ -> assert_failure "not parsed" -;; -let check_kolor = (fun k1 k2 -> - assert_equal k1.alpha k2.alpha - ; assert_equal k1.red k2.red - ; assert_equal k1.green k2.green - ; assert_equal k1.blue k2.blue) +let check_kolor = + fun k1 k2 -> + assert_equal k1.alpha k2.alpha; + assert_equal k1.red k2.red; + assert_equal k1.green k2.green; + assert_equal k1.blue k2.blue let test_kolor = create_test color_expr check_kolor -let color_tests = test_list test_kolor - [ - ("(color 0 0 0 0)", {red=0; green=0; blue=0; alpha=0}) - ] -;; +let color_tests = + test_list test_kolor + [ ("(color 0 0 0 0)", { red = 0; green = 0; blue = 0; alpha = 0 }) ] -let check_at = (fun (Coord(x1, y1)) (Coord(x2, y2)) -> assert_equal x1 x2; assert_equal y1 y2) +let check_at = + fun (Coord (x1, y1)) (Coord (x2, y2)) -> + assert_equal x1 x2; + assert_equal y1 y2 let test_at = create_test pin_at_coord_expr check_at +let at_tests = test_list test_at [ ("(at 0 0 0)", Coord (0, 0)) ] -let at_tests = test_list test_at - [ - ("(at 0 0 0)", Coord (0, 0)) - ] -;; -let check_justif = fun j {horiz; vert} -> assert_equal horiz j.horiz; assert_equal vert j.vert +let check_justif = + fun j { horiz; vert } -> + assert_equal horiz j.horiz; + assert_equal vert j.vert let test_justif = create_test justify_expr check_justif -let justif_tests = test_list test_justif +let justif_tests = + test_list test_justif [ - ("(justify left bottom)", {horiz=J_left; vert=J_bottom}) - ; ("(justify right center)", {horiz=J_right; vert=J_center}) - ; ("(justify center top)", {horiz=J_center; vert=J_top}) - ; ("(justify center top)", {horiz=J_center; vert=J_top}) - ; ("(justify center top)", {horiz=J_center; vert=J_top}) - ; ("(justify left bottom )", {horiz=J_left; vert=J_bottom}) + ("(justify left bottom)", { horiz = J_left; vert = J_bottom }); + ("(justify right center)", { horiz = J_right; vert = J_center }); + ("(justify center top)", { horiz = J_center; vert = J_top }); + ("(justify center top)", { horiz = J_center; vert = J_top }); + ("(justify center \t top)", { horiz = J_center; vert = J_top }); + ("(justify left bottom )", { horiz = J_left; vert = J_bottom }); ] -;; - -let check_font f {font; size; italic; bold; kolor} = - let Coord(x, y) = size in - let Coord(x_r, y_r) = f.size in - assert_equal italic f.italic; - assert_equal bold f.bold; - assert_equal x x_r; - assert_equal y y_r; - (match font, f.font with - | None, None -> () - | None, Some _ -> assert_failure "font name not found" - | Some _, None -> assert_failure "spurious font name" - | Some n1, Some n2 -> assert_equal n1 n2) -let test_font = create_test font_expr check_font +let check_font f { font; size; italic; bold; kolor } = + let (Coord (x, y)) = size in + let (Coord (x_r, y_r)) = f.size in + assert_equal italic f.italic; + assert_equal bold f.bold; + assert_equal x x_r; + assert_equal y y_r; + match (font, f.font) with + | None, None -> () + | None, Some _ -> assert_failure "font name not found" + | Some _, None -> assert_failure "spurious font name" + | Some n1, Some n2 -> assert_equal n1 n2 +let test_font = create_test font_expr check_font let font_tests = test_list test_font [ - ("(font (size 1.7526 1.7526))", {font=None; size=Coord(69, 69); italic=false; bold=false; kolor=None}) - ; ("(font (size 1.7526 1.7526) italic)", {font=None; size=Coord(69, 69); italic=true; bold=false; kolor=None}) - ; ("(font (size 1.7526 1.7526) bold)", {font=None; size=Coord(69, 69); italic=false; bold=true; kolor=None}) - ; ("(font (size 1.7526 1.7526) italic bold)", {font=None; size=Coord(69, 69); italic=true; bold=true; kolor=None}) - ; ("(font (size 1.7526 1.7526) italic bold (color 0 0 0 0))", {font=None; size=Coord(69, 69); italic=true; bold=true; kolor=Some{red=0; green=0; blue=0; alpha=0}}) - ; ("(font (size 1.7526 1.7526) (color 0 0 0 0))", {font=None; size=Coord(69, 69); italic=false; bold=false; kolor=Some{red=0; green=0; blue=0; alpha=0}}) + ( "(font (size 1.7526 1.7526))", + { + font = None; + size = Coord (69, 69); + italic = false; + bold = false; + kolor = None; + } ); + ( "(font (size 1.7526 1.7526) italic)", + { + font = None; + size = Coord (69, 69); + italic = true; + bold = false; + kolor = None; + } ); + ( "(font (size 1.7526 1.7526) bold)", + { + font = None; + size = Coord (69, 69); + italic = false; + bold = true; + kolor = None; + } ); + ( "(font (size 1.7526 1.7526) italic bold)", + { + font = None; + size = Coord (69, 69); + italic = true; + bold = true; + kolor = None; + } ); + ( "(font (size 1.7526 1.7526) italic bold (color 0 0 0 0))", + { + font = None; + size = Coord (69, 69); + italic = true; + bold = true; + kolor = Some { red = 0; green = 0; blue = 0; alpha = 0 }; + } ); + ( "(font (size 1.7526 1.7526) (color 0 0 0 0))", + { + font = None; + size = Coord (69, 69); + italic = false; + bold = false; + kolor = Some { red = 0; green = 0; blue = 0; alpha = 0 }; + } ); ] -;; let check_fill f1 f2 = assert_equal f1.fill_type f2.fill_type; @@ -108,99 +145,209 @@ let check_fill f1 f2 = let test_fill = create_test fill_expr check_fill -let fill_tests = test_list test_fill - [ ("(fill (type outline))", {fill_type=Outline_fill; kolor=None}) - ; ("(fill (type none))", {fill_type=No_fill; kolor=None}) - ; ("(fill (type background))", {fill_type=Background_fill; kolor=None}) +let fill_tests = + test_list test_fill + [ + ("(fill (type outline))", { fill_type = Outline_fill; kolor = None }); + ("(fill (type none))", { fill_type = No_fill; kolor = None }); + ("(fill (type background))", { fill_type = Background_fill; kolor = None }); ] -;; - -let check_property (p1: property) (p2: property) = +let check_property (p1 : property) (p2 : property) = assert_equal p1.name p2.name; assert_equal p1.value p2.value; assert_equal p1.id p2.id let test_property = create_test property_expr check_property -let property_tests = List.map ~f:(fun (expr, p) -> (expr >:: (fun _ -> test_property expr p))) +let property_tests = + List.map + ~f:(fun (expr, p) -> expr >:: fun _ -> test_property expr p) [ - ("(property \"Reference\" \"U\" (id 0) (at -4.6228 10.0584 0) - (effects (font (size 1.7526 1.7526)) (justify left bottom)))", {name="Reference"; value="U"; id=0; at=(Coord(-182, 396)); effects=Some {font={font=None; size=Coord(69, 69); italic=false; bold=false; kolor=None}; justify=Some {horiz=J_left; vert=J_bottom}; hide=false}}) - ; ("(property \"Reference\" \"U\" (id 0) (at -4.6228 10.0584 0))", {name="Reference"; value="U"; id=0; at=(Coord(-182, 396)); effects=Some {font={font=None; size=Coord(69, 69); italic=false; bold=false; kolor=None}; justify=Some {horiz=J_left; vert=J_bottom}; hide=false}}) + ( "(property \"Reference\" \"U\" (id 0) (at -4.6228 10.0584 0)\n\ + \ (effects (font (size 1.7526 1.7526)) (justify left bottom)))", + { + name = "Reference"; + value = "U"; + id = 0; + at = Coord (-182, 396); + effects = + Some + { + font = + { + font = None; + size = Coord (69, 69); + italic = false; + bold = false; + kolor = None; + }; + justify = Some { horiz = J_left; vert = J_bottom }; + hide = false; + }; + } ); + ( "(property \"Reference\" \"U\" (id 0) (at -4.6228 10.0584 0))", + { + name = "Reference"; + value = "U"; + id = 0; + at = Coord (-182, 396); + effects = + Some + { + font = + { + font = None; + size = Coord (69, 69); + italic = false; + bold = false; + kolor = None; + }; + justify = Some { horiz = J_left; vert = J_bottom }; + hide = false; + }; + } ); ] -;; - let assert_array_equal points1 points2 = - List.iter ~f:(fun ((RelCoord (x1, y1)), (RelCoord(x2, y2))) -> assert_equal x1 x2; assert_equal y1 y2) (List.combine points1 points2) + List.iter + ~f:(fun (RelCoord (x1, y1), RelCoord (x2, y2)) -> + assert_equal x1 x2; + assert_equal y1 y2) + (List.combine points1 points2) let assert_list_equal list1 list2 = - List.iter ~f:(fun (elt1, elt2) -> assert_equal elt1 elt2) (List.combine list1 list2) + List.iter + ~f:(fun (elt1, elt2) -> assert_equal elt1 elt2) + (List.combine list1 list2) - -let check_rectangle shape1 shape2 = - match shape1, shape2 with - | (Polygon (width1, points1)), (Polygon (width2, points2)) -> +let check_rectangle shape1 shape2 = + match (shape1, shape2) with + | Polygon (width1, points1), Polygon (width2, points2) -> assert_equal width1 width2; assert_array_equal points1 points2 | _, _ -> assert_failure "rectangle should be a polygon" let test_rectangle = create_test rectangle_expr check_rectangle -let rectangle_tests = test_list test_rectangle +let rectangle_tests = + test_list test_rectangle [ - ("(rectangle (start 178.7652 0) (end 179.3748 20.32) - (stroke (width 0)) (fill (type outline)) - )", Polygon (0, [ RelCoord(7038, 0); RelCoord(7038, 800); RelCoord(7062, 800); RelCoord(7062, 0); RelCoord(7038, 0)])) + ( "(rectangle (start 178.7652 0) (end 179.3748 20.32)\n\ + \ (stroke (width 0)) (fill (type outline))\n\ + \ )", + Polygon + ( 0, + [ + RelCoord (7038, 0); + RelCoord (7038, 800); + RelCoord (7062, 800); + RelCoord (7062, 0); + RelCoord (7038, 0); + ] ) ); ] -;; - -let check_pins p1 p2 = match (p1, p2) with - | ((Pin {name; number; length; contact=RelCoord (x1, y1); orient}), (Pin {name=name1; number=number1; length=length1; contact=RelCoord(x2, y2); orient=orient1})) ->( +let check_pins p1 p2 = + match (p1, p2) with + | ( Pin { name; number; length; contact = RelCoord (x1, y1); orient }, + Pin + { + name = name1; + number = number1; + length = length1; + contact = RelCoord (x2, y2); + orient = orient1; + } ) -> assert_equal name name1; assert_equal number number1; assert_equal length length1; assert_equal x1 x2; assert_equal y1 y2; - assert_equal orient orient1) + assert_equal orient orient1 | _, _ -> assert_failure "pins should be Pins" let test_pin = create_test pin_expr check_pins -let pin_tests = test_list test_pin +let pin_tests = + test_list test_pin [ - ({|(pin output line (at 17.78 2.54 180) (length 5.08) + ( {|(pin output line (at 17.78 2.54 180) (length 5.08) (name "S1" (effects (font (size 1.27 1.27)))) (number "1" (effects (font (size 1.27 1.27)))) - )|}, Pin {name=("S1", Size 50); number=("1", Size 50); length=Size 200; contact=RelCoord(700, 100); orient=P_L}); - ({|(pin input line (at -17.78 -5.08 0) (length 5.08) + )|}, + Pin + { + name = ("S1", Size 50); + number = ("1", Size 50); + length = Size 200; + contact = RelCoord (700, 100); + orient = P_L; + } ); + ( {|(pin input line (at -17.78 -5.08 0) (length 5.08) (name "G1" (effects (font (size 1.27 1.27)))) (number "2" (effects (font (size 1.27 1.27)))) ) -|}, Pin {name=("G1", Size 50); number=("2", Size 50); length=Size 200; contact=RelCoord(-700, -200); orient=P_R}); - ({|(pin bidirectional line (at 20.32 10.16 90) (length 5.08) +|}, + Pin + { + name = ("G1", Size 50); + number = ("2", Size 50); + length = Size 200; + contact = RelCoord (-700, -200); + orient = P_R; + } ); + ( {|(pin bidirectional line (at 20.32 10.16 90) (length 5.08) (name "VCC" (effects (font (size 1.27 1.27)))) (number "8" (effects (font (size 1.27 1.27)))) ) -|}, Pin {name=("VCC", Size 50); number=("8", Size 50); length=Size 200; contact=RelCoord(800, 400); orient=P_U}); - ({|(pin passive line (at 5.08 2.54 180) (length 3.81) +|}, + Pin + { + name = ("VCC", Size 50); + number = ("8", Size 50); + length = Size 200; + contact = RelCoord (800, 400); + orient = P_U; + } ); + ( {|(pin passive line (at 5.08 2.54 180) (length 3.81) (name "Pin_1" (effects (font (size 1.27 1.27)))) (number "1" (effects (font (size 1.27 1.27)))) ) -|}, Pin {name=("Pin_1", Size 50); number=("1", Size 50); length=Size 150; contact=RelCoord(200, 100); orient=P_L}); - ({|(pin passive line (at 5.08 0 180) (length 3.81) +|}, + Pin + { + name = ("Pin_1", Size 50); + number = ("1", Size 50); + length = Size 150; + contact = RelCoord (200, 100); + orient = P_L; + } ); + ( {|(pin passive line (at 5.08 0 180) (length 3.81) (name "Pin_2" (effects (font (size 1.27 1.27)))) (number "2" (effects (font (size 1.27 1.27)))) ) -|}, Pin {name=("Pin_2", Size 50); number=("2", Size 50); length=Size 150; contact=RelCoord(200, 0); orient=P_L}); - ({|(pin passive line (at 5.08 -2.54 180) (length 3.81) +|}, + Pin + { + name = ("Pin_2", Size 50); + number = ("2", Size 50); + length = Size 150; + contact = RelCoord (200, 0); + orient = P_L; + } ); + ( {|(pin passive line (at 5.08 -2.54 180) (length 3.81) (name "Pin_3" (effects (font (size 1.27 1.27)))) (number "3" (effects (font (size 1.27 1.27)))) - ) |}, Pin {name=("Pin_3", Size 50); number=("3", Size 50); length=Size 150; contact=RelCoord(200, -100); orient=P_L}) + ) |}, + Pin + { + name = ("Pin_3", Size 50); + number = ("3", Size 50); + length = Size 150; + contact = RelCoord (200, -100); + orient = P_L; + } ); ] -;; let check_angles (as1, ae1) (as2, ae2) = assert_equal as1 as2; @@ -208,12 +355,11 @@ let check_angles (as1, ae1) (as2, ae2) = let test_angles = create_test angles_expr check_angles -let angles_tests = test_list test_angles - [ ({|(angles -180.0 0.0) |}, (-180.0, 0.0)) - ] -;; +let angles_tests = + test_list test_angles [ ({|(angles -180.0 0.0) |}, (-180.0, 0.0)) ] -let check_radius (RelCoord(x1, y1), length1, (as1, ae1)) (RelCoord(x2, y2), length2, (as2, ae2)) = +let check_radius (RelCoord (x1, y1), length1, (as1, ae1)) + (RelCoord (x2, y2), length2, (as2, ae2)) = assert_equal ~msg:"x" x1 x2; assert_equal ~msg:"y" y1 y2; assert_equal ~msg:"angle start" as1 as2; @@ -222,101 +368,141 @@ let check_radius (RelCoord(x1, y1), length1, (as1, ae1)) (RelCoord(x2, y2), leng let test_radius = create_test radius_expr check_radius -let radius_tests = test_list test_radius - [({|(radius (at -6.985 -3.81) (length 1.905) (angles -180.0 0.0)) |}, - (RelCoord(-275, -150), 75, (-180.0, 0.0))) +let radius_tests = + test_list test_radius + [ + ( {|(radius (at -6.985 -3.81) (length 1.905) (angles -180.0 0.0)) |}, + (RelCoord (-275, -150), 75, (-180.0, 0.0)) ); ] -;; -let check_arcs a1 a2 = match (a1, a2) with - |Arc {s=Size s1; radius=radius1; sp=RelCoord(xs1, ys1); ep=RelCoord(xe1,ye1); center=RelCoord(xc1, yc1)}, Arc {s=Size s2; radius=radius2; sp=RelCoord(xs2, ys2); ep=RelCoord(xe2,ye2); center=RelCoord(xc2, yc2)} -> - assert_equal ~msg:"s1" s1 s2; - assert_equal ~msg:"radius1" radius1 radius2; - assert_equal ~msg:"xs1" xs1 xs1; - assert_equal ~msg:"xe1" xe1 xe2; - assert_equal ~msg:"xc1" xc1 xc2 - |_, _ -> assert_failure "not arcs!" +let check_arcs a1 a2 = + match (a1, a2) with + | ( Arc + { + s = Size s1; + radius = radius1; + sp = RelCoord (xs1, ys1); + ep = RelCoord (xe1, ye1); + center = RelCoord (xc1, yc1); + }, + Arc + { + s = Size s2; + radius = radius2; + sp = RelCoord (xs2, ys2); + ep = RelCoord (xe2, ye2); + center = RelCoord (xc2, yc2); + } ) -> + assert_equal ~msg:"s1" s1 s2; + assert_equal ~msg:"radius1" radius1 radius2; + assert_equal ~msg:"xs1" xs1 xs1; + assert_equal ~msg:"xe1" xe1 xe2; + assert_equal ~msg:"xc1" xc1 xc2 + | _, _ -> assert_failure "not arcs!" let test_arc = create_test arc_expr check_arcs -let arc_tests = test_list test_arc - [ ({|(arc (start -8.89 -3.81) (end -5.08 -3.81) (radius (at -6.985 -3.81) (length 1.905) (angles -179.9 -0.1)) +let arc_tests = + test_list test_arc + [ + ( {|(arc (start -8.89 -3.81) (end -5.08 -3.81) (radius (at -6.985 -3.81) (length 1.905) (angles -179.9 -0.1)) (stroke (width 0.508)) (fill (type none)) ) |}, - Arc {s=Size 20; radius=75; sp=RelCoord(-350, -150); ep=RelCoord(-200, -150); center=RelCoord(-275, -150)}) - ; ({|(arc (start -1.016 1.016) (end -1.016 -1.016) (radius (at -1.016 0) (length 1.016) (angles 90.1 -90.1)) + Arc + { + s = Size 20; + radius = 75; + sp = RelCoord (-350, -150); + ep = RelCoord (-200, -150); + center = RelCoord (-275, -150); + } ); + ( {|(arc (start -1.016 1.016) (end -1.016 -1.016) (radius (at -1.016 0) (length 1.016) (angles 90.1 -90.1)) (stroke (width 0)) (fill (type outline)) )|}, - Arc {s=Size 0; radius=40; sp=RelCoord(-40, 40); ep=RelCoord(-40, -40); center=RelCoord(-40, 0)}) + Arc + { + s = Size 0; + radius = 40; + sp = RelCoord (-40, 40); + ep = RelCoord (-40, -40); + center = RelCoord (-40, 0); + } ); ] -;; -let check_circles c1 c2 = match (c1, c2) with - | Circle (w1, {center=RelCoord(x1, y1); radius=radius1}), Circle (w2, {center=RelCoord(x2, y2); radius = radius2}) -> - assert_equal w1 w2; - assert_equal x1 x2; - assert_equal y1 y2; - assert_equal radius1 radius2 - | _, _ -> failwith "must be a circle!" +let check_circles c1 c2 = + match (c1, c2) with + | ( Circle (w1, { center = RelCoord (x1, y1); radius = radius1 }), + Circle (w2, { center = RelCoord (x2, y2); radius = radius2 }) ) -> + assert_equal w1 w2; + assert_equal x1 x2; + assert_equal y1 y2; + assert_equal radius1 radius2 + | _, _ -> failwith "must be a circle!" let test_circle = create_test circle_expr check_circles -let circle_tests = test_list test_circle - [ ({|(circle (center 0 1.27) (radius 1.27) (stroke (width 1.27)) (fill (type none))) +let circle_tests = + test_list test_circle + [ + ( {|(circle (center 0 1.27) (radius 1.27) (stroke (width 1.27)) (fill (type none))) |}, - Circle (50, {center=RelCoord(0, 50); radius=50})) - ; ({|(circle (center 0 1.27) (radius 1.27)) + Circle (50, { center = RelCoord (0, 50); radius = 50 }) ); + ( {|(circle (center 0 1.27) (radius 1.27)) |}, - Circle (1, {center=RelCoord(0, 50); radius=50})) + Circle (1, { center = RelCoord (0, 50); radius = 50 }) ); ] -;; -let check_bezier c1 c2 = match (c1, c2) with +let check_bezier c1 c2 = + match (c1, c2) with | Bezier (w1, points1), Bezier (w2, points2) -> - assert_equal w1 w2; - assert_array_equal points1 points2 - | _, _ -> failwith "must be a Bezier!" + assert_equal w1 w2; + assert_array_equal points1 points2 + | _, _ -> failwith "must be a Bezier!" let test_bezier = create_test bezier_expr check_bezier -let bezier_tests = test_list test_bezier - [ ({|(gr_curve +let bezier_tests = + test_list test_bezier + [ + ( {|(gr_curve (pts (xy 1.27 2.54) (xy 0.8636 2.54) ) (stroke (width 0.1524)) (fill (type none)) ) -|}, Bezier(6, [RelCoord(50, 100); RelCoord(34, 100)])) +|}, + Bezier (6, [ RelCoord (50, 100); RelCoord (34, 100) ]) ); ] -;; -let check_text c1 c2 = match (c1, c2) with - | Text {c=RelCoord(x1, y1); text=t1; s=Size s1}, Text {c=RelCoord(x2, y2); text=t2; s=Size s2} -> - assert_equal ~msg:"x1" x1 x2; - assert_equal ~msg:"y1" y1 y2; - assert_equal ~msg:"t1" t1 t2; - assert_equal ~msg:"s1" s1 s2 - | _, _ -> failwith "must be a Text!" +let check_text c1 c2 = + match (c1, c2) with + | ( Text { c = RelCoord (x1, y1); text = t1; s = Size s1 }, + Text { c = RelCoord (x2, y2); text = t2; s = Size s2 } ) -> + assert_equal ~msg:"x1" x1 x2; + assert_equal ~msg:"y1" y1 y2; + assert_equal ~msg:"t1" t1 t2; + assert_equal ~msg:"s1" s1 s2 + | _, _ -> failwith "must be a Text!" let test_text = create_test text_expr check_text -let text_tests = test_list test_text - [ ({|(text "mnt" (at 1.27 6.35 0) +let text_tests = + test_list test_text + [ + ( {|(text "mnt" (at 1.27 6.35 0) (effects (font (size 1.27 1.27))) ) |}, - Text {c=RelCoord(50, 250); text="mnt"; s=Size 50}) + Text { c = RelCoord (50, 250); text = "mnt"; s = Size 50 } ); ] -;; - -let check_unit u1 u2 = - assert_equal (List.length u1) (List.length u2) +let check_unit u1 u2 = assert_equal (List.length u1) (List.length u2) let test_unit = create_test unit_expr check_unit -let unit_tests = test_list test_unit +let unit_tests = + test_list test_unit [ - ({|(symbol "Conn_01x03_Male_1_1" + ( {|(symbol "Conn_01x03_Male_1_1" (rectangle (start 0.8636 -2.413) (end 0 -2.667) (stroke (width 0.1524)) (fill (type outline)) ) @@ -361,14 +547,13 @@ let unit_tests = test_list test_unit ) ) |}, - List.init ~len:9 ~f:(fun _ -> Field)) - ; ( {|(symbol "Conn_01x03_Male_1_1" - (rectangle (start 0.8636 -2.413)))|}, [ Field ]) - ; ( {|(symbol "Conn_01x03_Male_1_1") |}, [ ]) - - ] + List.init ~len:9 ~f:(fun _ -> Field) ); + ( {|(symbol "Conn_01x03_Male_1_1" + (rectangle (start 0.8636 -2.413)))|}, + [ Field ] ); + ({|(symbol "Conn_01x03_Male_1_1") |}, []); + ] -;; (* let check_component c1 c2 = let { names=names1 @@ -467,26 +652,28 @@ let component_tests = test_list test_component ] *) -let suite = "OUnit for " >::: - List.concat [[ "int expression" >:: test_int] - ; string_tests - ; at_tests - ; fill_tests - ; justif_tests - ; color_tests - ; font_tests - ; property_tests - ; rectangle_tests - ; pin_tests - ; angles_tests - ; radius_tests - ; circle_tests - ; bezier_tests - ; arc_tests - ; text_tests - (* ; unit_tests *) - (* ; component_tests *) - ] - -let _ = - run_test_tt_main suite +let suite = + "OUnit for " + >::: List.concat + [ + [ "int expression" >:: test_int ]; + string_tests; + at_tests; + fill_tests; + justif_tests; + color_tests; + font_tests; + property_tests; + rectangle_tests; + pin_tests; + angles_tests; + radius_tests; + circle_tests; + bezier_tests; + arc_tests; + text_tests + (* ; unit_tests *) + (* ; component_tests *); + ] + +let _ = run_test_tt_main suite diff --git a/kicadsch/test/test_real_v8_sch.ml b/kicadsch/test/test_real_v8_sch.ml index 53f44e4..c4b4a72 100644 --- a/kicadsch/test/test_real_v8_sch.ml +++ b/kicadsch/test/test_real_v8_sch.ml @@ -1,7 +1,6 @@ open OUnit open StdLabels - -module MUT = Kicadsch.V8.MakeSchPainter(StubPainter) +module MUT = Kicadsch.V8.MakeSchPainter (StubPainter) (* ── Helpers ─────────────────────────────────────────────────────────── *) @@ -9,8 +8,8 @@ let real_sch_file = "Non-Isolated AC-DC Power Module.kicad_sch" let read_file path = let ic = open_in path in - let n = in_channel_length ic in - let s = Bytes.create n in + let n = in_channel_length ic in + let s = Bytes.create n in really_input ic s 0 n; close_in ic; Bytes.to_string s @@ -21,24 +20,25 @@ let parse_file () = let content = read_file real_sch_file in MUT.parse_sheet (init ()) content -let output_file () = - StubPainter.write (MUT.output_context (parse_file ())) +let output_file () = StubPainter.write (MUT.output_context (parse_file ())) let filter_tag tag out = - List.filter ~f:(fun s -> + List.filter + ~f:(fun s -> let n = String.length tag + 1 in - String.length s >= n && - String.sub s ~pos:0 ~len:n = (tag ^ " ")) out + String.length s >= n && String.sub s ~pos:0 ~len:n = tag ^ " ") + out -let lines_of = filter_tag "Line" -let rects_of = filter_tag "Rect" -let texts_of = filter_tag "Text" +let lines_of = filter_tag "Line" +let rects_of = filter_tag "Rect" +let texts_of = filter_tag "Text" (* ── Tests ───────────────────────────────────────────────────────────── *) (* 1. The full real schematic parses without raising an exception. *) let test_full_parse () = - let _ = parse_file () in () + let _ = parse_file () in + () (* 2. A known horizontal wire is present. (xy 150.114 85.344) -> (xy 165.354 85.344) @@ -87,7 +87,8 @@ let test_title_label () = let out = output_file () in assert_bool "Title label text present with correct coords and size" (List.mem - "Text Red Non-Isolated AC-DC Power Supply Design Orient_H 9296 6705 400 J_left NoStyle" + "Text Red Non-Isolated AC-DC Power Supply Design Orient_H 9296 6705 400 \ + J_left NoStyle" ~set:(texts_of out)) (* 6. At least one component reference text is present (R1 resistor). @@ -122,15 +123,19 @@ let test_degenerate_rect () = (* ── Suite ────────────────────────────────────────────────────────────── *) -let suite = "Real V8 schematic integration" >::: - [ "full real schematic parses without exception" >:: test_full_parse - ; "known horizontal wire segment present" >:: test_known_wire - ; "bounding rectangle correct corners" >:: test_bounding_rect - ; "net label 5V correct coords and size" >:: test_label_5v - ; "title label correct text, coords, size" >:: test_title_label - ; "component reference R1 rendered correctly" >:: test_component_reference - ; "fields_autoplaced yes does not crash" >:: test_fields_autoplaced_does_not_crash - ; "degenerate zero-size rectangle present" >:: test_degenerate_rect - ] +let suite = + "Real V8 schematic integration" + >::: [ + "full real schematic parses without exception" >:: test_full_parse; + "known horizontal wire segment present" >:: test_known_wire; + "bounding rectangle correct corners" >:: test_bounding_rect; + "net label 5V correct coords and size" >:: test_label_5v; + "title label correct text, coords, size" >:: test_title_label; + "component reference R1 rendered correctly" + >:: test_component_reference; + "fields_autoplaced yes does not crash" + >:: test_fields_autoplaced_does_not_crash; + "degenerate zero-size rectangle present" >:: test_degenerate_rect; + ] let _ = run_test_tt_main suite diff --git a/kicadsch/test/test_sexp_kicad_parser.ml b/kicadsch/test/test_sexp_kicad_parser.ml index 72b1a52..c1d0108 100644 --- a/kicadsch/test/test_sexp_kicad_parser.ml +++ b/kicadsch/test/test_sexp_kicad_parser.ml @@ -4,80 +4,94 @@ open Kicadsch.Sigs open Kicadsch.Defs open Kicadsch.Sexp open Kicadsch.Lib_sigs -module Decode = Sexp_decode.Make(Base.Sexp) +module Decode = Sexp_decode.Make (Base.Sexp) (* module Csexp_i = Csexp.Make(Sexp) *) let create_test parser checker = - fun parse_expr expected_value -> + fun parse_expr expected_value -> let t = Parsexp.Single_and_positions.parse_string parse_expr in match t with - | Ok (res, pos) -> (match Decode.run_with_result parser res with + | Ok (res, pos) -> ( + match Decode.run_with_result parser res with | Ok r -> checker expected_value r - | Error sub -> - (match Parsexp.Positions.find_sub_sexp_phys pos res ~sub:sub with - | Some err_range -> assert_failure (Format.sprintf "%d:%d: Decode failed for %s" err_range.start_pos.line err_range.start_pos.col (Sexplib0.Sexp.to_string sub)) - | None -> assert_failure "decode failed!") - ) - | Error e -> assert_failure ( "not valid sexp " ^ (Parsexp__Parse_error.message e)) + | Error sub -> ( + match Parsexp.Positions.find_sub_sexp_phys pos res ~sub with + | Some err_range -> + assert_failure + (Format.sprintf "%d:%d: Decode failed for %s" + err_range.start_pos.line err_range.start_pos.col + (Sexplib0.Sexp.to_string sub)) + | None -> assert_failure "decode failed!")) + | Error e -> + assert_failure ("not valid sexp " ^ Parsexp__Parse_error.message e) let test_list single_test test_list = - List.map ~f: (fun (expr, j ) -> (expr >:: (fun _ -> (single_test expr j)))) test_list + List.map ~f:(fun (expr, j) -> expr >:: fun _ -> single_test expr j) test_list -;; -let check_yesno e1 e2 = assert_bool "yesno no match" ((e1 && e2) || (not e1 && not e2)) +let check_yesno e1 e2 = + assert_bool "yesno no match" ((e1 && e2) || ((not e1) && not e2)) let test_yesno = create_test (yesno_expr "foo") check_yesno -let yesno_tests = test_list test_yesno - [ ({|(foo yes) |}, true) - ; ({|(foo no)|}, false) - ; ({|(foo) |}, true) - ] -;; -let make_uuid u = match Uuidm.of_string u with +let yesno_tests = + test_list test_yesno + [ ({|(foo yes) |}, true); ({|(foo no)|}, false); ({|(foo) |}, true) ] + +let make_uuid u = + match Uuidm.of_string u with | Some uuid2 -> uuid2 | None -> raise (Invalid_argument ("internal error " ^ u)) let check_uuid u1 u2 = assert_bool "uuid do not match" (Uuidm.compare u1 u2 = 0) let test_uuid = create_test uuid_expr check_uuid -let uuid_tests = test_list test_uuid - [ ({|(uuid 072ad1ed-9172-426c-8e5d-41f1dcd4b625)|}, make_uuid "072ad1ed-9172-426c-8e5d-41f1dcd4b625") +let uuid_tests = + test_list test_uuid + [ + ( {|(uuid 072ad1ed-9172-426c-8e5d-41f1dcd4b625)|}, + make_uuid "072ad1ed-9172-426c-8e5d-41f1dcd4b625" ); ] -let check_kolor = (fun k1 k2 -> - assert_equal k1.alpha k2.alpha - ; assert_equal k1.red k2.red - ; assert_equal k1.green k2.green - ; assert_equal k1.blue k2.blue) + +let check_kolor = + fun k1 k2 -> + assert_equal k1.alpha k2.alpha; + assert_equal k1.red k2.red; + assert_equal k1.green k2.green; + assert_equal k1.blue k2.blue let test_kolor = create_test kolor_expr check_kolor -let color_tests = test_list test_kolor +let color_tests = + test_list test_kolor [ - ("(color 1 2 3 4)", {red=1; green=2; blue=3; alpha=4.}) - ; ("(color 4 3 2 1)", {red=4; green=3; blue=2; alpha=1.}) + ("(color 1 2 3 4)", { red = 1; green = 2; blue = 3; alpha = 4. }); + ("(color 4 3 2 1)", { red = 4; green = 3; blue = 2; alpha = 1. }); ] -;; -let check_at = (fun (Coord(x1, y1), a1) (Coord(x2, y2), a2) -> assert_equal x1 x2; assert_equal y1 y2; assert_equal a1 a2) +let check_at = + fun (Coord (x1, y1), a1) (Coord (x2, y2), a2) -> + assert_equal x1 x2; + assert_equal y1 y2; + assert_equal a1 a2 let test_at = create_test pin_at_coord_expr check_at -let at_tests = test_list test_at - [ ("(at 254 0 3)", (Coord (25400, 0), 3)) - ; ("(at 0 127)", (Coord (0, 12700), 0)) +let at_tests = + test_list test_at + [ + ("(at 254 0 3)", (Coord (25400, 0), 3)); + ("(at 0 127)", (Coord (0, 12700), 0)); ] -;; -let check_paper = (fun (Coord(x1, y1)) (Coord(x2, y2)) -> assert_equal ~printer:string_of_int x1 x2; assert_equal ~printer:string_of_int y1 y2) +let check_paper = + fun (Coord (x1, y1)) (Coord (x2, y2)) -> + assert_equal ~printer:string_of_int x1 x2; + assert_equal ~printer:string_of_int y1 y2 let test_paper = create_test paper_expr check_paper -let paper_tests = test_list test_paper - [ ({| (paper "A4") |}, Coord (29700, 21000)) - ] - -;; +let paper_tests = + test_list test_paper [ ({| (paper "A4") |}, Coord (29700, 21000)) ] let check_fill f1 f2 = assert_equal f1.fill_type f2.fill_type; @@ -85,178 +99,447 @@ let check_fill f1 f2 = let test_fill = create_test fill_expr check_fill -let fill_tests = test_list test_fill - [ ("(fill (type outline))", {fill_type=Some Outline_fill; kolor=None}) - ; ("(fill (type none))", {fill_type=Some No_fill; kolor=None}) - ; ("(fill (type background))", {fill_type=Some Background_fill; kolor=None}) - ; ("(fill (color 0 1 2 3.0))", {fill_type=None; kolor=Some {red=0; green=1; blue=2; alpha=3.}}) +let fill_tests = + test_list test_fill + [ + ("(fill (type outline))", { fill_type = Some Outline_fill; kolor = None }); + ("(fill (type none))", { fill_type = Some No_fill; kolor = None }); + ( "(fill (type background))", + { fill_type = Some Background_fill; kolor = None } ); + ( "(fill (color 0 1 2 3.0))", + { + fill_type = None; + kolor = Some { red = 0; green = 1; blue = 2; alpha = 3. }; + } ); ] -;; - -let check_justif = fun j {horiz; vert} -> assert_equal horiz j.horiz; assert_equal vert j.vert +let check_justif = + fun j { horiz; vert } -> + assert_equal horiz j.horiz; + assert_equal vert j.vert let test_justif = create_test justify_expr check_justif -let justif_tests = test_list test_justif +let justif_tests = + test_list test_justif [ - ("(justify left bottom)", {horiz=Some J_left; vert=Some J_bottom}) - ; ("(justify right center)", {horiz=Some J_right; vert=Some J_center}) - ; ("(justify center top)", {horiz=Some J_center; vert=Some J_top}) - ; ("(justify center top)", {horiz=Some J_center; vert=Some J_top}) - ; ("(justify center top)", {horiz=Some J_center; vert=Some J_top}) - ; ("(justify left bottom )", {horiz=Some J_left; vert=Some J_bottom}) + ("(justify left bottom)", { horiz = Some J_left; vert = Some J_bottom }); + ("(justify right center)", { horiz = Some J_right; vert = Some J_center }); + ("(justify center top)", { horiz = Some J_center; vert = Some J_top }); + ("(justify center top)", { horiz = Some J_center; vert = Some J_top }); + ("(justify center \t top)", { horiz = Some J_center; vert = Some J_top }); + ("(justify left bottom )", { horiz = Some J_left; vert = Some J_bottom }); ] -;; - -let check_font f {font; size; italic; bold; kolor} = - let Coord(x, y) = size in - let Coord(x_r, y_r) = f.size in - assert_equal italic f.italic; - assert_equal bold f.bold; - assert_equal x x_r; - assert_equal y y_r; - (match font, f.font with - | None, None -> () - | None, Some _ -> assert_failure "font name not found" - | Some _, None -> assert_failure "spurious font name" - | Some n1, Some n2 -> assert_equal n1 n2) -let test_font = create_test font_expr check_font +let check_font f { font; size; italic; bold; kolor } = + let (Coord (x, y)) = size in + let (Coord (x_r, y_r)) = f.size in + assert_equal italic f.italic; + assert_equal bold f.bold; + assert_equal x x_r; + assert_equal y y_r; + match (font, f.font) with + | None, None -> () + | None, Some _ -> assert_failure "font name not found" + | Some _, None -> assert_failure "spurious font name" + | Some n1, Some n2 -> assert_equal n1 n2 +let test_font = create_test font_expr check_font let font_tests = test_list test_font [ - ("(font (size 1.7526 1.7526))", {font=None; size=Coord(175, 175); italic=false; bold=false; kolor=None}) - ; ("(font (size 1.7526 1.7526) italic)", {font=None; size=Coord(175, 175); italic=true; bold=false; kolor=None}) - ; ("(font (size 1.7526 1.7526) bold)", {font=None; size=Coord(175, 175); italic=false; bold=true; kolor=None}) - ; ("(font (size 1.7526 1.7526) italic bold)", {font=None; size=Coord(175, 175); italic=true; bold=true; kolor=None}) - ; ("(font (size 1.7526 1.7526) italic bold (color 0 0 0 0))", {font=None; size=Coord(175, 175); italic=true; bold=true; kolor=Some{red=0; green=0; blue=0; alpha=0.}}) - ; ("(font (size 1.7526 1.7526) (color 0 0 0 0))", {font=None; size=Coord(175, 175); italic=false; bold=false; kolor=Some{red=0; green=0; blue=0; alpha=0.}}) + ( "(font (size 1.7526 1.7526))", + { + font = None; + size = Coord (175, 175); + italic = false; + bold = false; + kolor = None; + } ); + ( "(font (size 1.7526 1.7526) italic)", + { + font = None; + size = Coord (175, 175); + italic = true; + bold = false; + kolor = None; + } ); + ( "(font (size 1.7526 1.7526) bold)", + { + font = None; + size = Coord (175, 175); + italic = false; + bold = true; + kolor = None; + } ); + ( "(font (size 1.7526 1.7526) italic bold)", + { + font = None; + size = Coord (175, 175); + italic = true; + bold = true; + kolor = None; + } ); + ( "(font (size 1.7526 1.7526) italic bold (color 0 0 0 0))", + { + font = None; + size = Coord (175, 175); + italic = true; + bold = true; + kolor = Some { red = 0; green = 0; blue = 0; alpha = 0. }; + } ); + ( "(font (size 1.7526 1.7526) (color 0 0 0 0))", + { + font = None; + size = Coord (175, 175); + italic = false; + bold = false; + kolor = Some { red = 0; green = 0; blue = 0; alpha = 0. }; + } ); ] -;; - -let check_property (p1: property) (p2: property) = +let check_property (p1 : property) (p2 : property) = assert_equal p1.name p2.name; assert_equal p1.value p2.value; assert_equal p1.id p2.id let test_property = create_test property_expr check_property -let property_tests = List.map ~f:(fun (expr, p) -> (expr >:: (fun _ -> test_property expr p))) +let property_tests = + List.map + ~f:(fun (expr, p) -> expr >:: fun _ -> test_property expr p) [ - ("(property \"Reference\" \"U\" (id 0) (at -4.6228 10.0584 0) - (effects (font (size 1.7526 1.7526)) (justify left bottom)))", {name="Reference"; value="U"; id=0; at=(Coord(-182, 396)); rot =0; effects=Some {font={font=None; size=Coord(69, 69); italic=false; bold=false; kolor=None}; justify=Some {horiz=Some J_left; vert=Some J_bottom}; hide=false}}) - ; ("(property \"Reference\" \"U\" (id 0) (at -4.6228 10.0584 0))", {name="Reference"; value="U"; id=0; at=(Coord(-182, 396)); rot =0; effects=Some {font={font=None; size=Coord(69, 69); italic=false; bold=false; kolor=None}; justify=Some {horiz=Some J_left; vert=Some J_bottom}; hide=false}}) - ; ("(property \"Footprint\" \"\" (id 2) (at 0 0 0) - (effects (font (size 1.27 1.27)) hide) - )", - {name="Footprint"; value=""; id=2; at=(Coord(0, 0)); rot=0; effects=Some {font={font=None; size=Coord(50, 50); italic=false; bold=false; kolor=None}; justify=None; hide=true}}) - ; ({| (property "Références Inter-Feuilles" "${INTERSHEET_REFS}" (id 0) (at 71.6583 87.5506 0) + ( "(property \"Reference\" \"U\" (id 0) (at -4.6228 10.0584 0)\n\ + \ (effects (font (size 1.7526 1.7526)) (justify left bottom)))", + { + name = "Reference"; + value = "U"; + id = 0; + at = Coord (-182, 396); + rot = 0; + effects = + Some + { + font = + { + font = None; + size = Coord (69, 69); + italic = false; + bold = false; + kolor = None; + }; + justify = Some { horiz = Some J_left; vert = Some J_bottom }; + hide = false; + }; + } ); + ( "(property \"Reference\" \"U\" (id 0) (at -4.6228 10.0584 0))", + { + name = "Reference"; + value = "U"; + id = 0; + at = Coord (-182, 396); + rot = 0; + effects = + Some + { + font = + { + font = None; + size = Coord (69, 69); + italic = false; + bold = false; + kolor = None; + }; + justify = Some { horiz = Some J_left; vert = Some J_bottom }; + hide = false; + }; + } ); + ( "(property \"Footprint\" \"\" (id 2) (at 0 0 0)\n\ + \ (effects (font (size 1.27 1.27)) hide)\n\ + \ )", + { + name = "Footprint"; + value = ""; + id = 2; + at = Coord (0, 0); + rot = 0; + effects = + Some + { + font = + { + font = None; + size = Coord (50, 50); + italic = false; + bold = false; + kolor = None; + }; + justify = None; + hide = true; + }; + } ); + ( {| (property "Références Inter-Feuilles" "${INTERSHEET_REFS}" (id 0) (at 71.6583 87.5506 0) (effects (font (size 1.27 1.27)) (justify left) hide) )|}, - {name="Références Inter-Feuilles"; value="${INTERSHEET_REFS}"; id=0; at=(Coord(716583, 875506)); rot=0; effects=Some {font={font=None; size=Coord(50, 50); italic=false; bold=false; kolor=None}; justify=None; hide=true}}) - ; ({| (property "ki_description" "Power symbol creates a global label with name \"GNDPWR\" , global ground" (id 5) (at 0 0 0)) |}, - {name="ki_description"; value={|Power symbol creates a global label with name "GNDPWR" , global ground|}; id=5; at=(Coord(0, 0)); rot=0; effects=None}) - ; ({| (property "Reference" "#PWR" (at 0 -6.35 0) (effects (font (size 1.27 1.27)) hide)) |}, - {name="Reference"; value="#PWR"; id=0; at=(Coord(0, -635)); rot=0; effects=Some {font={font=None; size=Coord(50, 50); italic=false; bold=false; kolor=None}; justify=None; hide=true}}) - ; ({| (property "Références Inter-Feuilles" "${INTERSHEET_REFS}" (at 124.5394 76.3269 90) + { + name = "Références Inter-Feuilles"; + value = "${INTERSHEET_REFS}"; + id = 0; + at = Coord (716583, 875506); + rot = 0; + effects = + Some + { + font = + { + font = None; + size = Coord (50, 50); + italic = false; + bold = false; + kolor = None; + }; + justify = None; + hide = true; + }; + } ); + ( {| (property "ki_description" "Power symbol creates a global label with name \"GNDPWR\" , global ground" (id 5) (at 0 0 0)) |}, + { + name = "ki_description"; + value = + {|Power symbol creates a global label with name "GNDPWR" , global ground|}; + id = 5; + at = Coord (0, 0); + rot = 0; + effects = None; + } ); + ( {| (property "Reference" "#PWR" (at 0 -6.35 0) (effects (font (size 1.27 1.27)) hide)) |}, + { + name = "Reference"; + value = "#PWR"; + id = 0; + at = Coord (0, -635); + rot = 0; + effects = + Some + { + font = + { + font = None; + size = Coord (50, 50); + italic = false; + bold = false; + kolor = None; + }; + justify = None; + hide = true; + }; + } ); + ( {| (property "Références Inter-Feuilles" "${INTERSHEET_REFS}" (at 124.5394 76.3269 90) (effects (font (size 1.27 1.27)) (justify left) hide) ) |}, - {name="Références Inter-Feuilles"; value="${INTERSHEET_REFS}"; id=0; at=(Coord(1245394, 763269)); rot=90; effects=Some {font={font=None; size=Coord(50, 50); italic=false; bold=false; kolor=None}; justify=Some {horiz=Some J_left; vert=Some J_bottom}; hide=true}}) - - ] - -;; + { + name = "Références Inter-Feuilles"; + value = "${INTERSHEET_REFS}"; + id = 0; + at = Coord (1245394, 763269); + rot = 90; + effects = + Some + { + font = + { + font = None; + size = Coord (50, 50); + italic = false; + bold = false; + kolor = None; + }; + justify = Some { horiz = Some J_left; vert = Some J_bottom }; + hide = true; + }; + } ); + ] let assert_array_equal points1 points2 = - List.iter ~f:(fun ((RelCoord (x1, y1)), (RelCoord(x2, y2))) -> assert_equal ~cmp:Int.equal ~printer:string_of_int x1 x2; assert_equal ~cmp:Int.equal ~printer:string_of_int y1 y2) (List.combine points1 points2) + List.iter + ~f:(fun (RelCoord (x1, y1), RelCoord (x2, y2)) -> + assert_equal ~cmp:Int.equal ~printer:string_of_int x1 x2; + assert_equal ~cmp:Int.equal ~printer:string_of_int y1 y2) + (List.combine points1 points2) let assert_list_equal list1 list2 = - List.iter ~f:(fun (elt1, elt2) -> assert_equal elt1 elt2) (List.combine list1 list2) - + List.iter + ~f:(fun (elt1, elt2) -> assert_equal elt1 elt2) + (List.combine list1 list2) -let check_rectangle shape1 shape2 = - match shape1, shape2 with - | (Polygon (width1, points1)), (Polygon (width2, points2)) -> +let check_rectangle shape1 shape2 = + match (shape1, shape2) with + | Polygon (width1, points1), Polygon (width2, points2) -> assert_equal ~cmp:Int.equal ~printer:string_of_int width1 width2; assert_array_equal points1 points2 | _, _ -> assert_failure "rectangle should be a polygon" let test_rectangle = create_test rectangle_prim_expr check_rectangle -let rectangle_tests = test_list test_rectangle +let rectangle_tests = + test_list test_rectangle [ - ("(rectangle (start 178.7652 0) (end 179.3748 20.32) - (stroke (width 0)) (fill (type outline)) - )", Polygon (0, [ RelCoord(17876, 0); RelCoord(17876, 2032); RelCoord(17937, 2032); RelCoord(17937, 0); RelCoord(17876, 0)])) - ; ( "(rectangle (start 100.33 153.67) (end 106.68 160.02) - (stroke (width 0) (type default)) - (fill (type none)) - (uuid ae7453a5-3aa5-41db-95cd-dcabca1a7701) - )", Polygon(0, [RelCoord(10033, 15366); RelCoord(10033, 16002); RelCoord(10668, 16002); RelCoord(10668, 15366); RelCoord(10033, 15366)])) + ( "(rectangle (start 178.7652 0) (end 179.3748 20.32)\n\ + \ (stroke (width 0)) (fill (type outline))\n\ + \ )", + Polygon + ( 0, + [ + RelCoord (17876, 0); + RelCoord (17876, 2032); + RelCoord (17937, 2032); + RelCoord (17937, 0); + RelCoord (17876, 0); + ] ) ); + ( "(rectangle (start 100.33 153.67) (end 106.68 160.02)\n\ + \ (stroke (width 0) (type default))\n\ + \ (fill (type none))\n\ + \ (uuid ae7453a5-3aa5-41db-95cd-dcabca1a7701)\n\ + \ )", + Polygon + ( 0, + [ + RelCoord (10033, 15366); + RelCoord (10033, 16002); + RelCoord (10668, 16002); + RelCoord (10668, 15366); + RelCoord (10033, 15366); + ] ) ); ] -;; - -let check_pins p1 p2 = match (p1, p2) with - | ((Pin {name; number; length; contact=RelCoord (x1, y1); orient}), (Pin {name=name1; number=number1; length=length1; contact=RelCoord(x2, y2); orient=orient1})) ->( +let check_pins p1 p2 = + match (p1, p2) with + | ( Pin { name; number; length; contact = RelCoord (x1, y1); orient }, + Pin + { + name = name1; + number = number1; + length = length1; + contact = RelCoord (x2, y2); + orient = orient1; + } ) -> assert_equal name name1 ~printer:(fun (s, _) -> s); assert_equal number number1 ~printer:(fun (s, _) -> s); assert_equal length length1 ~printer:(fun (Size s) -> string_of_int s); assert_equal x1 x2 ~printer:string_of_int; assert_equal y1 y2 ~printer:string_of_int; - assert_equal orient orient1 ~printer:show_pin_orientation) + assert_equal orient orient1 ~printer:show_pin_orientation | _, _ -> assert_failure "pins should be Pins" let test_pin = create_test pin_expr check_pins -let pin_tests = test_list test_pin +let pin_tests = + test_list test_pin [ - ({|(pin output line (at 17.78 2.54 180) (length 5.08) + ( {|(pin output line (at 17.78 2.54 180) (length 5.08) (name "S1" (effects (font (size 1.27 1.27)))) (number "1" (effects (font (size 1.27 1.27)))) - )|}, Pin {name=("S1", Size 127); number=("1", Size 127); length=Size 508; contact=RelCoord(1778, 254); orient=P_L}); - ({|(pin input line (at -17.78 -5.08 0) (length 5.08) + )|}, + Pin + { + name = ("S1", Size 127); + number = ("1", Size 127); + length = Size 508; + contact = RelCoord (1778, 254); + orient = P_L; + } ); + ( {|(pin input line (at -17.78 -5.08 0) (length 5.08) (name "G1" (effects (font (size 1.27 1.27)))) (number "2" (effects (font (size 1.27 1.27)))) ) -|}, Pin {name=("G1", Size 127); number=("2", Size 127); length=Size 508; contact=RelCoord(-1778, -508); orient=P_R}); - ({|(pin bidirectional line (at 20.32 10.16 90) (length 5.08) +|}, + Pin + { + name = ("G1", Size 127); + number = ("2", Size 127); + length = Size 508; + contact = RelCoord (-1778, -508); + orient = P_R; + } ); + ( {|(pin bidirectional line (at 20.32 10.16 90) (length 5.08) (name "VCC" (effects (font (size 1.27 1.27)))) (number "8" (effects (font (size 1.27 1.27)))) ) -|}, Pin {name=("VCC", Size 127); number=("8", Size 127); length=Size 508; contact=RelCoord(2032, 1016); orient=P_U}); - ({|(pin passive line (at 5.08 2.54 180) (length 3.81) +|}, + Pin + { + name = ("VCC", Size 127); + number = ("8", Size 127); + length = Size 508; + contact = RelCoord (2032, 1016); + orient = P_U; + } ); + ( {|(pin passive line (at 5.08 2.54 180) (length 3.81) (name "Pin_1" (effects (font (size 1.27 1.27)))) (number "1" (effects (font (size 1.27 1.27)))) ) -|}, Pin {name=("Pin_1", Size 127); number=("1", Size 127); length=Size 381; contact=RelCoord(508, 254); orient=P_L}); - ({|(pin power_in line (at 5.08 0 180) (length 3.81) +|}, + Pin + { + name = ("Pin_1", Size 127); + number = ("1", Size 127); + length = Size 381; + contact = RelCoord (508, 254); + orient = P_L; + } ); + ( {|(pin power_in line (at 5.08 0 180) (length 3.81) (name "Pin_2" (effects (font (size 1.27 1.27)))) (number "2" (effects (font (size 1.27 1.27)))) ) -|}, Pin {name=("Pin_2", Size 127); number=("2", Size 127); length=Size 381; contact=RelCoord(508, 0); orient=P_L}); - ({|(pin passive line (at 5.08 -2.54 180) (length 3.81) +|}, + Pin + { + name = ("Pin_2", Size 127); + number = ("2", Size 127); + length = Size 381; + contact = RelCoord (508, 0); + orient = P_L; + } ); + ( {|(pin passive line (at 5.08 -2.54 180) (length 3.81) (name "Pin_3" (effects (font (size 1.27 1.27)))) (number "3" (effects (font (size 1.27 1.27)))) - ) |} - , Pin {name=("Pin_3", Size 127); number=("3", Size 127); length=Size 381; contact=RelCoord(508, -254); orient=P_L}) - ; ({|(pin power_in line (at 0 0 270) (length 0) hide + ) |}, + Pin + { + name = ("Pin_3", Size 127); + number = ("3", Size 127); + length = Size 381; + contact = RelCoord (508, -254); + orient = P_L; + } ); + ( {|(pin power_in line (at 0 0 270) (length 0) hide (name "GND" (effects (font (size 1.27 1.27)))) - (number "1" (effects (font (size 1.27 1.27))))) |} - , Pin {name=("GND", Size 127); number=("1", Size 127); length=Size 0; contact=RelCoord(0, 0); orient=P_D}) - ; ({|(pin bidirectional line (at -17.78 27.94 0) (length 2.54) + (number "1" (effects (font (size 1.27 1.27))))) |}, + Pin + { + name = ("GND", Size 127); + number = ("1", Size 127); + length = Size 0; + contact = RelCoord (0, 0); + orient = P_D; + } ); + ( {|(pin bidirectional line (at -17.78 27.94 0) (length 2.54) (name "PG10" (effects (font (size 1.27 1.27)))) (number "7" (effects (font (size 1.27 1.27)))) (alternate "DAC1_EXTI10" bidirectional line) (alternate "DAC3_EXTI10" bidirectional line) (alternate "RCC_MCO" bidirectional line) - )|} - , Pin {name=("PG10", Size 127); number=("7", Size 127); length=Size 254; contact=RelCoord(-1778, 2794); orient=P_R}) -; ({| (pin open_collector line + )|}, + Pin + { + name = ("PG10", Size 127); + number = ("7", Size 127); + length = Size 254; + contact = RelCoord (-1778, 2794); + orient = P_R; + } ); + ( {| (pin open_collector line (at 10.16 5.08 180) (length 2.54) (name "ALERT" @@ -273,24 +556,28 @@ let pin_tests = test_list test_pin ) ) ) -)|} - , Pin {name=("ALERT", Size 127); number=("3", Size 127); length=Size 254; contact=RelCoord(1016, 508);orient=P_L}) +)|}, + Pin + { + name = ("ALERT", Size 127); + number = ("3", Size 127); + length = Size 254; + contact = RelCoord (1016, 508); + orient = P_L; + } ); ] -;; - let check_angles (as1, ae1) (as2, ae2) = assert_equal as1 as2; assert_equal ae1 ae2 let test_angles = create_test angles_expr check_angles -let angles_tests = test_list test_angles - [ ({|(angles -180.0 0.0) |}, (-180.0, 0.0)) - ] -;; +let angles_tests = + test_list test_angles [ ({|(angles -180.0 0.0) |}, (-180.0, 0.0)) ] -let check_radius (RelCoord(x1, y1), length1, (as1, ae1)) (RelCoord(x2, y2), length2, (as2, ae2)) = +let check_radius (RelCoord (x1, y1), length1, (as1, ae1)) + (RelCoord (x2, y2), length2, (as2, ae2)) = assert_equal ~msg:"x" x1 x2; assert_equal ~msg:"y" y1 y2; assert_equal ~msg:"angle start" as1 as2; @@ -299,103 +586,141 @@ let check_radius (RelCoord(x1, y1), length1, (as1, ae1)) (RelCoord(x2, y2), leng let test_radius = create_test radius_expr check_radius -let radius_tests = test_list test_radius - [({|(radius (at -6.985 -3.81) (length 1.905) (angles -180.0 0.0)) |}, - (RelCoord(-698, -381), 190, (-180.0, 0.0))) +let radius_tests = + test_list test_radius + [ + ( {|(radius (at -6.985 -3.81) (length 1.905) (angles -180.0 0.0)) |}, + (RelCoord (-698, -381), 190, (-180.0, 0.0)) ); ] -;; - -let check_arcs a1 a2 = match (a1, a2) with - |Arc {s=Size s1; radius=radius1; sp=RelCoord(xs1, ys1); ep=RelCoord(xe1,ye1); center=RelCoord(xc1, yc1)}, Arc {s=Size s2; radius=radius2; sp=RelCoord(xs2, ys2); ep=RelCoord(xe2,ye2); center=RelCoord(xc2, yc2)} -> - assert_equal ~msg:"s1" s1 s2; - assert_equal ~msg:"radius1" radius1 radius2; - assert_equal ~msg:"xs1" xs1 xs1; - assert_equal ~msg:"xe1" xe1 xe2; - assert_equal ~msg:"xc1" xc1 xc2 - |_, _ -> assert_failure "not arcs!" +let check_arcs a1 a2 = + match (a1, a2) with + | ( Arc + { + s = Size s1; + radius = radius1; + sp = RelCoord (xs1, ys1); + ep = RelCoord (xe1, ye1); + center = RelCoord (xc1, yc1); + }, + Arc + { + s = Size s2; + radius = radius2; + sp = RelCoord (xs2, ys2); + ep = RelCoord (xe2, ye2); + center = RelCoord (xc2, yc2); + } ) -> + assert_equal ~msg:"s1" s1 s2; + assert_equal ~msg:"radius1" radius1 radius2; + assert_equal ~msg:"xs1" xs1 xs1; + assert_equal ~msg:"xe1" xe1 xe2; + assert_equal ~msg:"xc1" xc1 xc2 + | _, _ -> assert_failure "not arcs!" let test_arc = create_test arc_expr check_arcs -let arc_tests = test_list test_arc - [ ({|(arc (start -8.89 -3.81) (end -5.08 -3.81) (radius (at -6.985 -3.81) (length 1.905) (angles -179.9 -0.1)) +let arc_tests = + test_list test_arc + [ + ( {|(arc (start -8.89 -3.81) (end -5.08 -3.81) (radius (at -6.985 -3.81) (length 1.905) (angles -179.9 -0.1)) (stroke (width 0.508)) (fill (type none)) ) |}, - Arc {s=Size 50; radius=190; sp=RelCoord(-889, -381); ep=RelCoord(-508, -381); center=RelCoord(-698, -381)}) - ; ({|(arc (start -1.016 1.016) (end -1.016 -1.016) (radius (at -1.016 0) (length 1.016) (angles 90.1 -90.1)) + Arc + { + s = Size 50; + radius = 190; + sp = RelCoord (-889, -381); + ep = RelCoord (-508, -381); + center = RelCoord (-698, -381); + } ); + ( {|(arc (start -1.016 1.016) (end -1.016 -1.016) (radius (at -1.016 0) (length 1.016) (angles 90.1 -90.1)) (stroke (width 0)) (fill (type outline)) )|}, - Arc {s=Size 0; radius=101; sp=RelCoord(-101, 101); ep=RelCoord(-101, -101); center=RelCoord(-101, 0)}) + Arc + { + s = Size 0; + radius = 101; + sp = RelCoord (-101, 101); + ep = RelCoord (-101, -101); + center = RelCoord (-101, 0); + } ); ] -;; -let check_bezier c1 c2 = match (c1, c2) with +let check_bezier c1 c2 = + match (c1, c2) with | Bezier (w1, points1), Bezier (w2, points2) -> - assert_equal w1 w2; - assert_array_equal points1 points2 - | _, _ -> failwith "must be a Bezier!" + assert_equal w1 w2; + assert_array_equal points1 points2 + | _, _ -> failwith "must be a Bezier!" let test_bezier = create_test bezier_expr check_bezier -let bezier_tests = test_list test_bezier - [ ({|(gr_curve +let bezier_tests = + test_list test_bezier + [ + ( {|(gr_curve (pts (xy 1.27 2.54) (xy 0.86 2.54) ) (stroke (width 0.1524)) (fill (type none)) ) -|}, Bezier(15, [RelCoord(127, 254); RelCoord(86, 254)])) +|}, + Bezier (15, [ RelCoord (127, 254); RelCoord (86, 254) ]) ); ] -;; -let check_circles c1 c2 = match (c1, c2) with - | Circle (w1, {center=RelCoord(x1, y1); radius=radius1}), Circle (w2, {center=RelCoord(x2, y2); radius = radius2}) -> - assert_equal w1 w2; - assert_equal x1 x2; - assert_equal y1 y2; - assert_equal radius1 radius2 - | _, _ -> failwith "must be a circle!" +let check_circles c1 c2 = + match (c1, c2) with + | ( Circle (w1, { center = RelCoord (x1, y1); radius = radius1 }), + Circle (w2, { center = RelCoord (x2, y2); radius = radius2 }) ) -> + assert_equal w1 w2; + assert_equal x1 x2; + assert_equal y1 y2; + assert_equal radius1 radius2 + | _, _ -> failwith "must be a circle!" let test_circle = create_test circle_expr check_circles -let circle_tests = test_list test_circle - [ ({|(circle (center 0 1.27) (radius 1.27) (stroke (width 1.27)) (fill (type none))) +let circle_tests = + test_list test_circle + [ + ( {|(circle (center 0 1.27) (radius 1.27) (stroke (width 1.27)) (fill (type none))) |}, - Circle (127, {center=RelCoord(0, 127); radius=127})) - ; ({|(circle (center 0 1.27) (radius 1.27)) + Circle (127, { center = RelCoord (0, 127); radius = 127 }) ); + ( {|(circle (center 0 1.27) (radius 1.27)) |}, - Circle (10, {center=RelCoord(0, 127); radius=127})) + Circle (10, { center = RelCoord (0, 127); radius = 127 }) ); ] -;; -let check_text c1 c2 = match (c1, c2) with - | Text {c=RelCoord(x1, y1); text=t1; s=Size s1}, Text {c=RelCoord(x2, y2); text=t2; s=Size s2} -> - assert_equal ~msg:"x1" x1 x2; - assert_equal ~msg:"y1" y1 y2; - assert_equal ~msg:"t1" t1 t2; - assert_equal ~msg:"s1" s1 s2 - | _, _ -> failwith "must be a Text!" +let check_text c1 c2 = + match (c1, c2) with + | ( Text { c = RelCoord (x1, y1); text = t1; s = Size s1 }, + Text { c = RelCoord (x2, y2); text = t2; s = Size s2 } ) -> + assert_equal ~msg:"x1" x1 x2; + assert_equal ~msg:"y1" y1 y2; + assert_equal ~msg:"t1" t1 t2; + assert_equal ~msg:"s1" s1 s2 + | _, _ -> failwith "must be a Text!" let test_text = create_test text_expr check_text -let text_tests = test_list test_text - [ ({|(text "mnt" (at 1.27 6.35 0) +let text_tests = + test_list test_text + [ + ( {|(text "mnt" (at 1.27 6.35 0) (effects (font (size 1.27 1.27))) ) |}, - Text {c=RelCoord(127, 635); text="mnt"; s=Size 127}) + Text { c = RelCoord (127, 635); text = "mnt"; s = Size 127 } ); ] -;; - -let check_unit u1 u2 = - assert_equal (List.length u1) (List.length u2) - +let check_unit u1 u2 = assert_equal (List.length u1) (List.length u2) let test_unit = create_test unit_expr check_unit -let unit_tests = test_list test_unit +let unit_tests = + test_list test_unit [ - ({|(symbol "Conn_01x03_Male_1_1" + ( {|(symbol "Conn_01x03_Male_1_1" (rectangle (start 0.8636 -2.413) (end 0 -2.667) (stroke (width 0.1524)) (fill (type outline)) ) @@ -440,40 +765,43 @@ let unit_tests = test_list test_unit ) ) |}, - List.init ~len:9 ~f:(fun _ -> Field)) - ; ( {|(symbol "Conn_01x03_Male_1_1" - (rectangle (start 0.8636 -2.413) (end -0.8636 2.413)))|}, [ Field ]) - ; ( {|(symbol "Conn_01x03_Male_1_1") |}, [ ]) - - ] - -;; + List.init ~len:9 ~f:(fun _ -> Field) ); + ( {|(symbol "Conn_01x03_Male_1_1" + (rectangle (start 0.8636 -2.413) (end -0.8636 2.413)))|}, + [ Field ] ); + ({|(symbol "Conn_01x03_Male_1_1") |}, []); + ] let check_component c1 c2 = - let { names=names1 - ; draw_pnum=draw_pnum1 - ; draw_pname= draw_pname1 - ; multi = multi1 - ; graph = graph1 - } = c1 and - { names=names2 - ; draw_pnum=draw_pnum2 - ; draw_pname= draw_pname2 - ; multi = multi2 - ; graph = graph2 - } = c2 in + let { + names = names1; + draw_pnum = draw_pnum1; + draw_pname = draw_pname1; + multi = multi1; + graph = graph1; + } = + c1 + and { + names = names2; + draw_pnum = draw_pnum2; + draw_pname = draw_pname2; + multi = multi2; + graph = graph2; + } = + c2 + in assert_bool "print name not equal" (Bool.equal draw_pname1 draw_pname2); assert_bool "print number not equal" (Bool.equal draw_pnum1 draw_pnum2); assert_bool "multi not equal" (Bool.equal multi1 multi2); assert_list_equal names1 names2; assert_equal (List.length graph1) (List.length graph2) -;; - let test_component = create_test symbol_expr check_component -let component_tests = test_list test_component - [ ({|(symbol "Connector:Conn_01x03_Male" (pin_names (offset 1.016) hide) (in_bom yes) (on_board yes) +let component_tests = + test_list test_component + [ + ( {|(symbol "Connector:Conn_01x03_Male" (pin_names (offset 1.016) hide) (in_bom yes) (on_board yes) (property "Reference" "J" (id 0) (at 0 5.08 0) (effects (font (size 1.27 1.27))) ) @@ -539,13 +867,15 @@ let component_tests = test_list test_component (number "3" (effects (font (size 1.27 1.27)))) ) ) - )|} - , { names=["Connector:Conn_01x03_Male"] - ; draw_pnum=true - ; draw_pname=false - ; multi=false - ; graph=List.init ~len:9 ~f:(fun _ -> {parts=1; prim=Field})}) - ; ({| + )|}, + { + names = [ "Connector:Conn_01x03_Male" ]; + draw_pnum = true; + draw_pname = false; + multi = false; + graph = List.init ~len:9 ~f:(fun _ -> { parts = 1; prim = Field }); + } ); + ( {| (symbol "power:GND" (power) (pin_names (offset 0)) (in_bom yes) (on_board yes) (property "Reference" "#PWR" (id 0) (at 0 -6.35 0) (effects (font (size 1.27 1.27)) hide) @@ -586,13 +916,15 @@ let component_tests = test_list test_component ) ) ) - |} - , { names=["power:GND"] - ; draw_pnum=true - ; draw_pname=false - ; multi=false - ; graph=List.init ~len:2 ~f:(fun _ -> {parts=1; prim=Field})}) - ; ( {| + |}, + { + names = [ "power:GND" ]; + draw_pnum = true; + draw_pname = false; + multi = false; + graph = List.init ~len:2 ~f:(fun _ -> { parts = 1; prim = Field }); + } ); + ( {| (symbol "Analog_ADC:ADS1015IDGS" (in_bom yes) (on_board yes) (property "Reference" "U" (id 0) (at 2.54 13.97 0) (effects (font (size 1.27 1.27))) @@ -664,53 +996,60 @@ let component_tests = test_list test_component ) ) ) |}, - { names=["Analog_ADC:ADS1015IDGS"] - ; draw_pnum=true - ; draw_pname=true - ; multi=false - ; graph=List.init ~len:11 ~f:(fun _ -> {parts=1; prim=Field})}) + { + names = [ "Analog_ADC:ADS1015IDGS" ]; + draw_pnum = true; + draw_pname = true; + multi = false; + graph = List.init ~len:11 ~f:(fun _ -> { parts = 1; prim = Field }); + } ); ] -;; - let test_junction = create_test junction_expr check_paper -let junction_tests = test_list test_junction - [ ("(junction (at 254 0) (diameter 0.9144) (color 0 0 0 0))", Coord (25400, 0)) - ; ("(junction (at 49.53 151.13) (diameter 0) (color 0 0 0 0))", Coord (4953, 15113)) +let junction_tests = + test_list test_junction + [ + ( "(junction (at 254 0) (diameter 0.9144) (color 0 0 0 0))", + Coord (25400, 0) ); + ( "(junction (at 49.53 151.13) (diameter 0) (color 0 0 0 0))", + Coord (4953, 15113) ); ] -;; let test_no_connect = create_test no_connect_expr check_paper -let no_connect_tests = test_list test_no_connect - [ ("(no_connect (at 254 0) (uuid e8352a79-c40d-4cf1-97a7-2bb649ced79a))", Coord (25400, 0)) - ; ("(no_connect (at 49.53 151.13) (uuid e8352a79-c40d-4cf1-97a7-2bb649ced79a))", Coord (4953, 15113)) +let no_connect_tests = + test_list test_no_connect + [ + ( "(no_connect (at 254 0) (uuid e8352a79-c40d-4cf1-97a7-2bb649ced79a))", + Coord (25400, 0) ); + ( "(no_connect (at 49.53 151.13) (uuid \ + e8352a79-c40d-4cf1-97a7-2bb649ced79a))", + Coord (4953, 15113) ); ] -;; - let check_alternate () () = () - let test_alternate = create_test pin_alternate_args check_alternate -let alternate_tests = test_list test_alternate - [ ({|(alternate "VREFBUF_OUT" bidirectional line)|}, ()) - ; ({|(alternate "ADC1_IN10" bidirectional line)|}, ()) +let alternate_tests = + test_list test_alternate + [ + ({|(alternate "VREFBUF_OUT" bidirectional line)|}, ()); + ({|(alternate "ADC1_IN10" bidirectional line)|}, ()); ] let test_sch_pin = create_test sch_pin_expr (fun _ _ -> ()) -let sch_pin_tests = test_list test_sch_pin - [ ({|(pin "1" (uuid 7829cc5e-c0ba-483b-8ef1-279a374fd70e))|}, () ) - ] - -;; +let sch_pin_tests = + test_list test_sch_pin + [ ({|(pin "1" (uuid 7829cc5e-c0ba-483b-8ef1-279a374fd70e))|}, ()) ] let test_sch_symbol = create_test sch_symbol_expr (fun _ _ -> ()) -let sch_symbol_tests = test_list test_sch_symbol - [ ({|(symbol (lib_id "Switch:SW_Rotary12") (at 123.19 101.6 180) (unit 1) +let sch_symbol_tests = + test_list test_sch_symbol + [ + ( {|(symbol (lib_id "Switch:SW_Rotary12") (at 123.19 101.6 180) (unit 1) (in_bom yes) (on_board yes) (fields_autoplaced) (uuid d1df6972-c898-47bb-9c11-b133529d84e6) (property "Reference" "SW?" (id 0) (at 126.0475 81.28 0)) @@ -734,13 +1073,16 @@ let sch_symbol_tests = test_list test_sch_symbol (pin "7" (uuid 9712e705-cada-4c71-8e1b-e8b5d0669b50)) (pin "8" (uuid 39105380-e6cd-4a90-9748-cb3de7e4ffa2)) (pin "9" (uuid b408cfea-98f0-460b-8b24-4722609632a0)) - )|}, ()) + )|}, + () ); ] -;; + let test_lib_symbols = create_test lib_symbols_expr (fun _ _ -> ()) -let lib_symbols_tests = test_list test_lib_symbols - [ ({| (lib_symbols +let lib_symbols_tests = + test_list test_lib_symbols + [ + ( {| (lib_symbols (symbol "power:GND" (power) (pin_names (offset 0)) (in_bom yes) (on_board yes) (property "Reference" "#PWR" (at 0 -6.35 0) (effects (font (size 1.27 1.27)) hide) @@ -781,53 +1123,64 @@ let lib_symbols_tests = test_list test_lib_symbols ) ) ) - ) |}, ()) - ] - + ) |}, + () ); + ] -;; -let test_pts = create_test pts_expr (fun l1 l2 -> List.iter2 ~f:(fun (Coord(x1, y1)) (Coord(x2, y2)) -> assert_equal x1 x2; assert_equal y1 y2) l1 l2) +let test_pts = + create_test pts_expr (fun l1 l2 -> + List.iter2 + ~f:(fun (Coord (x1, y1)) (Coord (x2, y2)) -> + assert_equal x1 x2; + assert_equal y1 y2) + l1 l2) -let pts_tests = test_list test_pts - [ ("(pts (xy 29.21 68.58) (xy 59.69 68.58))", [Coord(2921, 6858); Coord(5969, 6858)]) +let pts_tests = + test_list test_pts + [ + ( "(pts (xy 29.21 68.58) (xy 59.69 68.58))", + [ Coord (2921, 6858); Coord (5969, 6858) ] ); ] -;; - let test_wire = create_test wire_expr (fun _ _ -> ()) -let wire_tests = test_list test_wire - - [ ({|(wire (pts (xy 29.21 68.58) (xy 59.69 68.58)) +let wire_tests = + test_list test_wire + [ + ( {|(wire (pts (xy 29.21 68.58) (xy 59.69 68.58)) (stroke (width 0) (type default) (color 0 0 0 0)) (uuid 78aef266-32d4-439c-9762-afe709cb660f) - )|}, ()) - ; ({|(wire (pts (xy 29.21 68.58) (xy 59.69 68.58)) + )|}, + () ); + ( {|(wire (pts (xy 29.21 68.58) (xy 59.69 68.58)) (stroke (width 0) (type default)) (uuid 78aef266-32d4-439c-9762-afe709cb660f) - )|}, ()) - ] - -;; + )|}, + () ); + ] -let check_global_label (Coord(x1, y1), r1, text1, (Size s1), shape1, j1) (Coord (x2, y2), r2, text2, (Size s2), shape2, j2) = +let check_global_label (Coord (x1, y1), r1, text1, Size s1, shape1, j1) + (Coord (x2, y2), r2, text2, Size s2, shape2, j2) = assert_equal x1 x2 ~printer:string_of_int; assert_equal y1 y2 ~printer:string_of_int; assert_equal r1 r2 ~printer:string_of_int; - assert_equal text1 text2 ~printer:(fun c->c); + assert_equal text1 text2 ~printer:(fun c -> c); assert_equal s1 s2 ~printer:string_of_int let test_global_test = create_test global_label_expr check_global_label -let global_label_tests = test_list test_global_test - [ ({| (global_label "test 1" (shape input) (at 63.5 87.63 0) (fields_autoplaced) +let global_label_tests = + test_list test_global_test + [ + ( {| (global_label "test 1" (shape input) (at 63.5 87.63 0) (fields_autoplaced) (effects (font (size 1.27 1.27)) (justify left)) (uuid 2cee9329-354d-4eab-887d-c615701cca76) (property "Références Inter-Feuilles" "${INTERSHEET_REFS}" (id 0) (at 71.6583 87.5506 0) (effects (font (size 1.27 1.27)) (justify left) hide) ) - )|}, (Coord(6350, 8763), 0, "test 1", (Size 127), InputPort, J_left)) - ; {| (global_label "GO3" (shape output) (at 124.46 82.55 90) (fields_autoplaced) + )|}, + (Coord (6350, 8763), 0, "test 1", Size 127, InputPort, J_left) ); + ( {| (global_label "GO3" (shape output) (at 124.46 82.55 90) (fields_autoplaced) (effects (font (size 1.27 1.27)) (justify left)) (uuid 10c8ec0b-9471-485f-995e-5254544feb64) (property "Intersheetrefs" "${INTERSHEET_REFS}" (at 124.46 82.55 0) @@ -836,58 +1189,58 @@ let global_label_tests = test_list test_global_test (property "Références Inter-Feuilles" "${INTERSHEET_REFS}" (at 124.5394 76.3269 90) (effects (font (size 1.27 1.27)) (justify left) hide) ) - ) |}, (Coord(12446, 8255), 90, "GO3", (Size 127), OutputPort, J_left) - - ] - -;; + ) |}, + (Coord (12446, 8255), 90, "GO3", Size 127, OutputPort, J_left) ); + ] let check_sheet_project _ _ = () - let test_sheet_project = create_test sheet_instances_expr check_sheet_project -let sheet_project_tests = test_list test_sheet_project [ - ({| +let sheet_project_tests = + test_list test_sheet_project + [ + ( {| (instances (project "test" (path "/011bafac-76a0-4e40-aeda-a97ad2c79980" (page "2")) ) ) - |} - , () ) + |}, + () ); ] -let suite = "OUnit for " >::: - List.concat - [ alternate_tests - ; yesno_tests - ; uuid_tests - ; paper_tests - ; at_tests - ; fill_tests - ; justif_tests - ; color_tests - ; font_tests - ; property_tests - ; rectangle_tests - ; pin_tests - ; angles_tests - ; radius_tests - ; arc_tests - ; bezier_tests - ; circle_tests - ; text_tests - ; unit_tests - ; component_tests - ; junction_tests - ; no_connect_tests - ; sch_pin_tests - ; sch_symbol_tests - ; lib_symbols_tests - ; wire_tests - ; global_label_tests - ; sheet_project_tests - ] - -let _ = - run_test_tt_main suite +let suite = + "OUnit for " + >::: List.concat + [ + alternate_tests; + yesno_tests; + uuid_tests; + paper_tests; + at_tests; + fill_tests; + justif_tests; + color_tests; + font_tests; + property_tests; + rectangle_tests; + pin_tests; + angles_tests; + radius_tests; + arc_tests; + bezier_tests; + circle_tests; + text_tests; + unit_tests; + component_tests; + junction_tests; + no_connect_tests; + sch_pin_tests; + sch_symbol_tests; + lib_symbols_tests; + wire_tests; + global_label_tests; + sheet_project_tests; + ] + +let _ = run_test_tt_main suite diff --git a/pkg/pkg.ml b/pkg/pkg.ml old mode 100755 new mode 100644 index 64a7b16..de9fb11 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -1,11 +1,10 @@ #!/usr/bin/env ocaml + #use "topfind" + #require "topkg-jbuilder" open Topkg -let publish = - Pkg.publish ~artefacts:[`Distrib] () - -let () = - Topkg_jbuilder.describe ~name:"kicadsch" ~publish () +let publish = Pkg.publish ~artefacts:[ `Distrib ] () +let () = Topkg_jbuilder.describe ~name:"kicadsch" ~publish () diff --git a/plotkicadsch.opam b/plotkicadsch.opam index 8813d02..d8edc8a 100644 --- a/plotkicadsch.opam +++ b/plotkicadsch.opam @@ -1,31 +1,42 @@ +# This file is generated by dune, edit dune-project instead opam-version: "2.0" -maintainer: "Jean-Noël Avila " -authors: "Jean-Noël Avila " -homepage: "https://jnavila.github.io/plotkicadsch/" +version: "0.4.0" +synopsis: "A command line tool to plot and compare KiCad schematics" +description: + "plotkicadsch lets you export Kicad schematics to SVG, up to version 9, while plotgitsch lets you compare git revisions of the schematic pages" +maintainer: ["Jean-Noël Avila "] +authors: ["Jean-Noël Avila "] +license: "GPL-2.0-or-later" +homepage: "https://github.com/jnavila/plotkicadsch" bug-reports: "https://github.com/jnavila/plotkicadsch/issues" -doc: "https://jnavila.github.io/plotkicadsch/index" -synopsis: "Utilities to print and compare version of Kicad schematics" -description: """ -Two utilities: - * plotkicadsch is able to plot schematic sheets to SVG files - * plotgitsch is able to compare git revisions of schematics -""" -license: "ISC" -dev-repo: "git+https://github.com/jnavila/plotkicadsch.git" -build: [ - [ "dune" "subst" ] {dev} - [ "dune" "build" "-p" name "-j" jobs] -] depends: [ - "ocaml" {>="4.09"} - "dune" {>= "1.0"} - "kicadsch" {= version} - "tyxml" {>= "4.0.0"} - "lwt" - "lwt_ppx" {build} - "sha" - "git" {>= "3.4.0"} - "git-unix" - "base64" {>= "3.0.0"} + "ocaml" + "base64" + "kicadsch" + "digestif" + "dune" {>= "2.9"} "cmdliner" + "lwt_ppx" + "ppx_deriving" + "tyxml" + "git-unix" + "sha" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "--promote-install-files=false" + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["dune" "install" "-p" name "--create-install-files" name] ] +dev-repo: "git+https://github.com/jnavila/plotkicadsch" diff --git a/plotkicadsch/src/boundingBox.ml b/plotkicadsch/src/boundingBox.ml index fc814de..320dfb3 100644 --- a/plotkicadsch/src/boundingBox.ml +++ b/plotkicadsch/src/boundingBox.ml @@ -1,56 +1,76 @@ open Kicadsch.Sigs -type t = { left_inf: coord; right_sup: coord} +type t = { left_inf : coord; right_sup : coord } let create () = - { left_inf= Coord(10000000000, 1000000000); right_sup = Coord(-100000, -100000)} + { + left_inf = Coord (10000000000, 1000000000); + right_sup = Coord (-100000, -100000); + } -let create_from_rect (Coord (x, y) as c1) (Coord (width, height)) = - { left_inf= c1; right_sup= Coord(x+width, y+height)} +let create_from_rect (Coord (x, y) as c1) (Coord (width, height)) = + { left_inf = c1; right_sup = Coord (x + width, y + height) } let create_from_limits (Coord (x1, y1)) (Coord (x2, y2)) = - { left_inf= Coord ( (min x1 x2), (min y1 y2)); right_sup= Coord((max x1 x2),(max y1 y2))} + { + left_inf = Coord (min x1 x2, min y1 y2); + right_sup = Coord (max x1 x2, max y1 y2); + } -let add_rect {left_inf=Coord(xli_1, yli_1); right_sup=Coord(xrs_1, yrs_1)} {left_inf=Coord(xli_2, yli_2); right_sup=Coord(xrs_2, yrs_2)} = - { left_inf= Coord ((min xli_1 xli_2), (min yli_1 yli_2)); right_sup = Coord((max xrs_1 xrs_2), (max yrs_1 yrs_2))} +let add_rect + { left_inf = Coord (xli_1, yli_1); right_sup = Coord (xrs_1, yrs_1) } + { left_inf = Coord (xli_2, yli_2); right_sup = Coord (xrs_2, yrs_2) } = + { + left_inf = Coord (min xli_1 xli_2, min yli_1 yli_2); + right_sup = Coord (max xrs_1 xrs_2, max yrs_1 yrs_2); + } -let add_point {left_inf=Coord(xli, yli); right_sup=Coord(xrs, yrs) } (Coord(x, y)) = - { left_inf= Coord ((min xli x), (min yli y)); right_sup = Coord((max xrs x), (max yrs y))} +let add_point { left_inf = Coord (xli, yli); right_sup = Coord (xrs, yrs) } + (Coord (x, y)) = + { + left_inf = Coord (min xli x, min yli y); + right_sup = Coord (max xrs x, max yrs y); + } -let reformat ~min_size ~extend {left_inf=Coord(xli, yli); right_sup=Coord(xrs, yrs)} = - let resize li rs = if (rs -li) < min_size then - let middle = (rs + li ) / 2 in - middle - min_size/2, middle + min_size/2 - else - li - extend, rs + extend in +let reformat ~min_size ~extend + { left_inf = Coord (xli, yli); right_sup = Coord (xrs, yrs) } = + let resize li rs = + if rs - li < min_size then + let middle = (rs + li) / 2 in + (middle - (min_size / 2), middle + (min_size / 2)) + else (li - extend, rs + extend) + in let xmin, xmax = resize xli xrs and ymin, ymax = resize yli yrs in - {left_inf=Coord(xmin, ymin); right_sup=Coord(xmax, ymax) } + { left_inf = Coord (xmin, ymin); right_sup = Coord (xmax, ymax) } -let as_rect {left_inf=Coord(xli, yli) as c1; right_sup=Coord(xrs, yrs) } = - c1, Coord (xrs - xli, yrs - yli) +let as_rect { left_inf = Coord (xli, yli) as c1; right_sup = Coord (xrs, yrs) } + = + (c1, Coord (xrs - xli, yrs - yli)) -let overlap_ratio {left_inf=Coord(xli_1, yli_1); right_sup=Coord(xrs_1, yrs_1)} {left_inf=Coord(xli_2, yli_2); right_sup=Coord(xrs_2, yrs_2)} = - let xli = max xli_1 xli_2 and yli = max yli_1 yli_2 and xrs = min xrs_1 xrs_2 and yrs = min yrs_1 yrs_2 in - let intersected = (xli < xrs) && (yli < yrs) in +let overlap_ratio + { left_inf = Coord (xli_1, yli_1); right_sup = Coord (xrs_1, yrs_1) } + { left_inf = Coord (xli_2, yli_2); right_sup = Coord (xrs_2, yrs_2) } = + let xli = max xli_1 xli_2 + and yli = max yli_1 yli_2 + and xrs = min xrs_1 xrs_2 + and yrs = min yrs_1 yrs_2 in + let intersected = xli < xrs && yli < yrs in if intersected then - let surface = (xrs - xli)* (yrs - yli) and - surface_1 = (xrs_1 - xli_1)* (yrs_1 - yli_1) and - surface_2 = (xrs_2 - xli_2)* (yrs_2 - yli_2) in - (float (max surface_1 surface_2) ) /. (float surface) - else - 0.0 - -let compare {left_inf=Coord(xli_1, yli_1); right_sup=Coord(xrs_1, yrs_1)} {left_inf=Coord(xli_2, yli_2); right_sup=Coord(xrs_2, yrs_2)} : int = + let surface = (xrs - xli) * (yrs - yli) + and surface_1 = (xrs_1 - xli_1) * (yrs_1 - yli_1) + and surface_2 = (xrs_2 - xli_2) * (yrs_2 - yli_2) in + float (max surface_1 surface_2) /. float surface + else 0.0 + +let compare + { left_inf = Coord (xli_1, yli_1); right_sup = Coord (xrs_1, yrs_1) } + { left_inf = Coord (xli_2, yli_2); right_sup = Coord (xrs_2, yrs_2) } : int + = let xli_r = xli_1 - xli_2 in if xli_r == 0 then - let yli_r = yli_1 - yli_2 in - if (yli_r == 0) then - let xrs_r = xrs_1 - xrs_2 in - if xrs_r == 0 then - yrs_1 - yrs_2 - else - xrs_r - else - yli_r - else - xli_r + let yli_r = yli_1 - yli_2 in + if yli_r == 0 then + let xrs_r = xrs_1 - xrs_2 in + if xrs_r == 0 then yrs_1 - yrs_2 else xrs_r + else yli_r + else xli_r diff --git a/plotkicadsch/src/boundingBox.mli b/plotkicadsch/src/boundingBox.mli index 59486e5..80e3b46 100644 --- a/plotkicadsch/src/boundingBox.mli +++ b/plotkicadsch/src/boundingBox.mli @@ -2,19 +2,12 @@ open Kicadsch.Sigs type t -val create: unit -> t - -val create_from_rect: coord -> coord -> t - -val create_from_limits: coord -> coord -> t - -val add_rect: t -> t -> t - -val add_point: t -> coord -> t - -val reformat: min_size:int -> extend:int -> t -> t -val as_rect: t -> coord*coord - -val overlap_ratio: t -> t -> float - -val compare: t -> t -> int +val create : unit -> t +val create_from_rect : coord -> coord -> t +val create_from_limits : coord -> coord -> t +val add_rect : t -> t -> t +val add_point : t -> coord -> t +val reformat : min_size:int -> extend:int -> t -> t +val as_rect : t -> coord * coord +val overlap_ratio : t -> t -> float +val compare : t -> t -> int diff --git a/plotkicadsch/src/diffFs.ml b/plotkicadsch/src/diffFs.ml index b8bfa10..5c3a489 100644 --- a/plotkicadsch/src/diffFs.ml +++ b/plotkicadsch/src/diffFs.ml @@ -1,11 +1,7 @@ - type t = TrueFS of string | GitFS of string module type Simple_FS = sig - val label : t - val get_content : string list -> string Lwt.t - val list_files : (string -> bool) -> (string list * string) list Lwt.t end diff --git a/plotkicadsch/src/dune b/plotkicadsch/src/dune index 2de5a19..f1364f2 100644 --- a/plotkicadsch/src/dune +++ b/plotkicadsch/src/dune @@ -1,24 +1,23 @@ (executables - (names plotgitsch plotkicadsch) - (public_names plotgitsch plotkicadsch) - (package plotkicadsch) - (preprocess (pps lwt_ppx)) - (libraries - kicadsch - tyxml - digestif.c - git-unix - lwt - lwt.unix - sha - base64 - cmdliner - ) - (flags (:standard -w -3 -safe-string)) -) + (names plotgitsch plotkicadsch) + (public_names plotgitsch plotkicadsch) + (package plotkicadsch) + (preprocess + (pps lwt_ppx)) + (libraries + kicadsch + tyxml + digestif.c + git-unix + lwt + lwt.unix + sha + base64 + cmdliner) + (flags + (:standard -w -3 -safe-string))) - (install - (package plotkicadsch) - (section bin) - (files git-imgdiff) - ) +(install + (package plotkicadsch) + (section bin) + (files git-imgdiff)) diff --git a/plotkicadsch/src/gitFs.ml b/plotkicadsch/src/gitFs.ml index 5f888e4..18f5111 100644 --- a/plotkicadsch/src/gitFs.ml +++ b/plotkicadsch/src/gitFs.ml @@ -1,17 +1,20 @@ open StdLabels open Lwt.Infix open DiffFs + exception InternalGitError of string exception PathNotFound of string list let make commitish relative_path = - ( module struct + (module struct open Git_unix module Search = Git.Search.Make (Digestif.SHA1) (Store) + let rev_parse r = - SysAbst.pread "git" [|"rev-parse"; r ^ "^{commit}"|] - >>= fun s -> - try Lwt.return @@ Store.Hash.of_hex @@ String.sub ~pos:0 s ~len:(min 40 (String.length s)) + SysAbst.pread "git" [| "rev-parse"; r ^ "^{commit}" |] >>= fun s -> + try + Lwt.return @@ Store.Hash.of_hex + @@ String.sub ~pos:0 s ~len:(min 40 (String.length s)) with _ -> Lwt.fail (InternalGitError ("cannot parse rev " ^ r)) let label = GitFS commitish @@ -26,30 +29,28 @@ let make commitish relative_path = try%lwt let%lwt _ = Lwt_unix.stat new_gitdir in (* that's a git repo and d is the root *) - Lwt.return (match relative_path with - | None -> (d, b) - | Some p -> (d, String.split_on_char ~sep:'/' p)) + Lwt.return + (match relative_path with + | None -> (d, b) + | Some p -> (d, String.split_on_char ~sep:'/' p)) with | UnixLabels.Unix_error (UnixLabels.ENOENT, _, _) -> - let new_d = dirname d in - if String.equal new_d d then - (* we've reached the root of the FS *) - Lwt.fail (InternalGitError "not in a git repository") - else - let new_b = basename d :: b in - recurse (new_d, new_b) - | e -> - raise e + let new_d = dirname d in + if String.equal new_d d then + (* we've reached the root of the FS *) + Lwt.fail (InternalGitError "not in a git repository") + else + let new_b = basename d :: b in + recurse (new_d, new_b) + | e -> raise e in recurse @@ (Sys.getcwd (), []) let fs = let%lwt root, _ = git_root in match%lwt Store.v (Fpath.v root) with - | Ok s -> - Lwt.return s - | Error e -> - Lwt.fail (InternalGitError (Fmt.strf "%a" Store.pp_error e)) + | Ok s -> Lwt.return s + | Error e -> Lwt.fail (InternalGitError (Fmt.strf "%a" Store.pp_error e)) let theref = rev_parse commitish @@ -58,73 +59,69 @@ let make commitish relative_path = let%lwt h = theref in let%lwt _, rel_path = git_root in match%lwt - Search.find t h (`Commit (`Path (List.concat [rel_path; path]))) + Search.find t h (`Commit (`Path (List.concat [ rel_path; path ]))) with - | None -> - Lwt.fail - (PathNotFound path) + | None -> Lwt.fail (PathNotFound path) | Some sha -> ( match%lwt Store.read t sha with - | Ok a -> - action a + | Ok a -> action a | Error e -> - Lwt.fail (InternalGitError (Fmt.strf "%a" Store.pp_error e)) ) + Lwt.fail (InternalGitError (Fmt.strf "%a" Store.pp_error e))) let get_content filename = try%lwt begin - with_path filename - @@ fun res -> match res with - | Git.Value.Blob b -> - Lwt.return (Store.Value.Blob.to_string b) - | _ -> - Lwt.fail (InternalGitError "not a valid path") + with_path filename @@ fun res -> + match res with + | Git.Value.Blob b -> Lwt.return (Store.Value.Blob.to_string b) + | _ -> Lwt.fail (InternalGitError "not a valid path") end - with - PathNotFound _ -> Lwt.return "" + with PathNotFound _ -> Lwt.return "" - let find_file_local filter (t: Store.Value.Tree.t) = + let find_file_local filter (t : Store.Value.Tree.t) = let open Git.Tree in to_list t - |> List.filter_map ~f:(fun t -> let {node; name; _} = t in - if filter name then Some ([name], Store.Hash.to_hex node) else None - ) - ;; + |> List.filter_map ~f:(fun t -> + let { node; name; _ } = t in + if filter name then Some ([ name ], Store.Hash.to_hex node) else None) let find_dir_local t = let open Git.Tree in - to_list t - |> List.filter ~f:(fun {perm;_} -> perm == `Dir) - ;; + to_list t |> List.filter ~f:(fun { perm; _ } -> perm == `Dir) let rec recurse_dir ?dirname node pattern = - let rename name = match dirname with - | Some dirname -> dirname::name - | None -> name in + let rename name = + match dirname with Some dirname -> dirname :: name | None -> name + in let local_file_list = find_file_local pattern node in - let path_file_list = List.map local_file_list ~f:(fun (name, hash) -> ((rename name), hash)) in + let path_file_list = + List.map local_file_list ~f:(fun (name, hash) -> (rename name, hash)) + in let dirs = find_dir_local node in let%lwt t = fs in let open Git.Tree in - let recurse_tree = fun entry -> - let%lwt res = Store.read t entry.node in - match res with - |Error e -> Lwt.fail (InternalGitError (Fmt.strf "%a" Store.pp_error e)) - |Ok Git.Value.Tree t ->( + let recurse_tree = + fun entry -> + let%lwt res = Store.read t entry.node in + match res with + | Error e -> + Lwt.fail (InternalGitError (Fmt.strf "%a" Store.pp_error e)) + | Ok (Git.Value.Tree t) -> let%lwt subdir = recurse_dir ~dirname:entry.name t pattern in - let subdir_files = List.map ~f:(fun (name, hash) -> ((rename name), hash)) subdir in - Lwt.return subdir_files) - |Ok _ -> Lwt.fail (InternalGitError ("impossible case")) in + let subdir_files = + List.map ~f:(fun (name, hash) -> (rename name, hash)) subdir + in + Lwt.return subdir_files + | Ok _ -> Lwt.fail (InternalGitError "impossible case") + in let%lwt subdir_list = Lwt_list.map_s recurse_tree dirs in - let result = List.concat [List.concat subdir_list; path_file_list] in + let result = List.concat [ List.concat subdir_list; path_file_list ] in Lwt.return result let list_files_from path pattern = - with_path path - @@ function + with_path path @@ function | Git.Value.Tree t -> recurse_dir t pattern | _ -> Lwt.fail (InternalGitError "not a tree!") - let list_files pattern =list_files_from [] pattern - end - : Simple_FS ) + let list_files pattern = list_files_from [] pattern + end : Simple_FS) diff --git a/plotkicadsch/src/imageDiff.ml b/plotkicadsch/src/imageDiff.ml index 119153b..da0dc57 100644 --- a/plotkicadsch/src/imageDiff.ml +++ b/plotkicadsch/src/imageDiff.ml @@ -6,6 +6,7 @@ let doc = "use compare (ImageMagick) between bitmaps" type pctx = SvgPainter.t module SVG = Kicadsch.V8.MakeSchPainter (SvgPainter) + module SP = struct include SVG @@ -20,33 +21,27 @@ let display_diff ~from_ctx ~to_ctx filename ~keep = let both_files = List.map ~f:(fun (svg_name, context) -> - Lwt_io.with_file ~mode:Lwt_io.Output svg_name (fun o -> - Lwt_io.write o (SvgPainter.write context) ) ) - [(from_filename, from_ctx); (to_filename, to_ctx)] + Lwt_io.with_file ~mode:Lwt_io.Output svg_name (fun o -> + Lwt_io.write o (SvgPainter.write context))) + [ (from_filename, from_ctx); (to_filename, to_ctx) ] in let both = Lwt.join both_files in let compare_them = - both - >>= fun _ -> - SysAbst.exec "git-imgdiff" [|from_filename; to_filename|] + both >>= fun _ -> + SysAbst.exec "git-imgdiff" [| from_filename; to_filename |] >|= let open UnixLabels in - function - | WEXITED ret -> - if Int.equal ret 0 then true else false - | WSIGNALED _ -> - false - | WSTOPPED _ -> - false + function + | WEXITED ret -> if Int.equal ret 0 then true else false + | WSIGNALED _ -> false + | WSTOPPED _ -> false in let%lwt ret = try%lwt compare_them with - | GitFs.InternalGitError s -> - Lwt_io.printf "%s\n" s >|= fun () -> false - | _ -> - Lwt_io.printf "unknown error\n" >|= fun () -> false + | GitFs.InternalGitError s -> Lwt_io.printf "%s\n" s >|= fun () -> false + | _ -> Lwt_io.printf "unknown error\n" >|= fun () -> false in Lwt.join @@ List.map - ~f:(SysAbst.finalize_tmp_file ~keep) - [from_filename; to_filename] + ~f:(SysAbst.finalize_tmp_file ~keep) + [ from_filename; to_filename ] >|= fun _ -> ret diff --git a/plotkicadsch/src/internalDiff.ml b/plotkicadsch/src/internalDiff.ml index c5e9c21..7990caf 100644 --- a/plotkicadsch/src/internalDiff.ml +++ b/plotkicadsch/src/internalDiff.ml @@ -2,10 +2,8 @@ open! StdLabels open Lwt.Infix open Kicadsch.Defs open Kicadsch.Sigs - include DiffTool - -module L = Kicadsch.V8.MakeSchPainter(ListPainter.L) +module L = Kicadsch.V8.MakeSchPainter (ListPainter.L) module LP = struct include L @@ -13,8 +11,9 @@ module LP = struct type painterContext = ListPainter.listcanevas end -let internal_diff (d : string) (c : SvgPainter.diff_colors option) (z: string option) = - ( module struct +let internal_diff (d : string) (c : SvgPainter.diff_colors option) + (z : string option) = + (module struct let doc = "internal diff and show with " ^ d type pctx = ListPainter.listcanevas @@ -27,126 +26,134 @@ let internal_diff (d : string) (c : SvgPainter.diff_colors option) (z: string op let open ListPainter in let module O = SvgPainter in let kolor = - match style with - | Theirs -> - `Old - | Ours -> - `New - | Idem -> - `ForeGround + match style with Theirs -> `Old | Ours -> `New | Idem -> `ForeGround in match arg with | Text (_, text, o, c, s, j, style) -> - O.paint_text ~kolor text o c s j style out_ctx + O.paint_text ~kolor text o c s j style out_ctx | Line (_, s, from_, to_) -> - O.paint_line ~kolor ~width:s from_ to_ out_ctx - | Rect (_, _, c1, c2) -> - O.paint_rect ~kolor c1 c2 out_ctx + O.paint_line ~kolor ~width:s from_ to_ out_ctx + | Rect (_, _, c1, c2) -> O.paint_rect ~kolor c1 c2 out_ctx | Circle (_, _, center, radius) -> - O.paint_circle ~kolor center radius out_ctx + O.paint_circle ~kolor center radius out_ctx | Ellipse (_, _, center, major_radius, minor_radius, rotation_angle) -> - O.paint_ellipse ~kolor center major_radius minor_radius rotation_angle out_ctx - | EllipseArc (_, _, center, major_radius, minor_radius, rotation_angle, start_angle, end_angle) -> - O.paint_ellipse_arc ~kolor center major_radius minor_radius rotation_angle start_angle end_angle out_ctx + O.paint_ellipse ~kolor center major_radius minor_radius rotation_angle + out_ctx + | EllipseArc + ( _, + _, + center, + major_radius, + minor_radius, + rotation_angle, + start_angle, + end_angle ) -> + O.paint_ellipse_arc ~kolor center major_radius minor_radius + rotation_angle start_angle end_angle out_ctx | Arc (_, _, center, start_, end_, radius) -> - O.paint_arc ~kolor center start_ end_ radius out_ctx - | Image (corner, scale, data) -> - O.paint_image corner scale data out_ctx - | Format (Coord (x, y)) -> - O.set_canevas_size x y out_ctx - | Zone (c1, c2) -> - O.paint_zone c1 c2 out_ctx + O.paint_arc ~kolor center start_ end_ radius out_ctx + | Image (corner, scale, data) -> O.paint_image corner scale data out_ctx + | Format (Coord (x, y)) -> O.set_canevas_size x y out_ctx + | Zone (c1, c2) -> O.paint_zone c1 c2 out_ctx let text_bbox text o c s j = (* TODO: vertical text does not work *) let len = String.length text in - let Size sz = s in - let Coord (x,y) = c in + let (Size sz) = s in + let (Coord (x, y)) = c in let shift = match j with - | J_right | J_bottom -> -sz*len/2 - | J_center -> - sz*len/4 + | J_right | J_bottom -> -sz * len / 2 + | J_center -> -sz * len / 4 | J_left | J_top -> 0 in match o with | Orient_H -> - BoundingBox.create_from_rect (Coord (x+shift,y)) (Coord (sz*len/2,sz/2)) + BoundingBox.create_from_rect + (Coord (x + shift, y)) + (Coord (sz * len / 2, sz / 2)) | Orient_V -> - BoundingBox.create_from_rect (Coord (x, y-sz*len/2+shift)) (Coord (sz/2, sz*len/2)) + BoundingBox.create_from_rect + (Coord (x, y - (sz * len / 2) + shift)) + (Coord (sz / 2, sz * len / 2)) let elt_rect elt = let open ListPainter in let module BB = BoundingBox in match elt with - | Text (_, text, o, c, s, j, _) -> - text_bbox text o c s j - | Line (_, _, f, t) -> - BB.create_from_limits f t - | Rect (_, _, c1, c2) - | Zone (c1, c2) -> - BB.create_from_rect c1 c2 + | Text (_, text, o, c, s, j, _) -> text_bbox text o c s j + | Line (_, _, f, t) -> BB.create_from_limits f t + | Rect (_, _, c1, c2) | Zone (c1, c2) -> BB.create_from_rect c1 c2 | Circle (_, _, center, radius) -> - let Coord(x,y) = center in - BB.create_from_limits (Coord(x-radius, y-radius)) (Coord(x+radius,y+radius)) + let (Coord (x, y)) = center in + BB.create_from_limits + (Coord (x - radius, y - radius)) + (Coord (x + radius, y + radius)) | Ellipse (_, _, center, major_radius, minor_radius, _) -> - let Coord(x,y) = center in - let mr = max major_radius minor_radius in - BB.create_from_limits (Coord(x-mr, y-mr)) (Coord(x+mr,y+mr)) + let (Coord (x, y)) = center in + let mr = max major_radius minor_radius in + BB.create_from_limits + (Coord (x - mr, y - mr)) + (Coord (x + mr, y + mr)) | EllipseArc (_, _, center, major_radius, minor_radius, _, _, _) -> - let Coord(x,y) = center in - let mr = max major_radius minor_radius in - BB.create_from_limits (Coord(x-mr, y-mr)) (Coord(x+mr,y+mr)) - | Arc (_ , _, center, _, _, radius) -> - (* TODO: take into count partial angle *) - let Coord(x, y) = center in - BB.create_from_limits (Coord(x-radius, y-radius)) (Coord(x+radius,y+radius)) + let (Coord (x, y)) = center in + let mr = max major_radius minor_radius in + BB.create_from_limits + (Coord (x - mr, y - mr)) + (Coord (x + mr, y + mr)) + | Arc (_, _, center, _, _, radius) -> + (* TODO: take into count partial angle *) + let (Coord (x, y)) = center in + BB.create_from_limits + (Coord (x - radius, y - radius)) + (Coord (x + radius, y + radius)) | Image (corner, _, data) -> - let w, h = SvgPainter.get_png_dims data in - BB.create_from_rect corner (Coord(w, h)) + let w, h = SvgPainter.get_png_dims data in + BB.create_from_rect corner (Coord (w, h)) | Format _ -> BB.create () - let dispatch_rect (res, acc) elt = - if (BoundingBox.overlap_ratio res elt) > 0.9 then - BoundingBox.add_rect res elt , acc - else - res, elt::acc + let dispatch_rect (res, acc) elt = + if BoundingBox.overlap_ratio res elt > 0.9 then + (BoundingBox.add_rect res elt, acc) + else (res, elt :: acc) let rec aggregate rect rect_list = - let result, remaining = List.fold_left ~f:dispatch_rect ~init:(rect, []) rect_list in + let result, remaining = + List.fold_left ~f:dispatch_rect ~init:(rect, []) rect_list + in if Int.equal (List.length remaining) (List.length rect_list) then - result, remaining - else - aggregate result remaining + (result, remaining) + else aggregate result remaining - let merge_rects rects:BoundingBox.t list = + let merge_rects rects : BoundingBox.t list = let rec aggregate_list out_list = function - | rect::l -> - let res, remaining = aggregate rect l in - let res2, remaining2 = aggregate res out_list in - aggregate_list (res2::remaining2) remaining - | [] -> out_list , [] in + | rect :: l -> + let res, remaining = aggregate rect l in + let res2, remaining2 = aggregate res out_list in + aggregate_list (res2 :: remaining2) remaining + | [] -> (out_list, []) + in fst (aggregate_list [] rects) let draw_bb ctx r = - let c1, c2 = BoundingBox.as_rect r in + let c1, c2 = BoundingBox.as_rect r in SvgPainter.paint_zone c1 c2 ctx - let refine_segments (Coord (x1, y1), _) (Coord (x1', y1'), Coord (x2', y2')) = - if (Int.compare x1 x1' == 0) - then - ((Int.compare y1 y1') * (Int.compare x1 x2')) - else - Int.compare y1 y2' + let refine_segments (Coord (x1, y1), _) (Coord (x1', y1'), Coord (x2', y2')) + = + if Int.compare x1 x1' == 0 then Int.compare y1 y1' * Int.compare x1 x2' + else Int.compare y1 y2' let compare s1 s2 : int = - let s1_r = elt_rect s1 - and s2_r = elt_rect s2 in + let s1_r = elt_rect s1 and s2_r = elt_rect s2 in let bb_comp = BoundingBox.compare s1_r s2_r in if bb_comp == 0 then - match s1, s2 with - | Text (_, t1, _, _, _, _ , _), Text (_, t2, _, _, _, _, _) -> String.compare t1 t2 + match (s1, s2) with + | Text (_, t1, _, _, _, _, _), Text (_, t2, _, _, _, _, _) -> + String.compare t1 t2 | Rect _, Rect _ -> 0 - | Line (_, _ , c1, c2), Line(_, _, c1', c2') -> refine_segments (c1, c2) (c1', c2') + | Line (_, _, c1, c2), Line (_, _, c1', c2') -> + refine_segments (c1, c2) (c1', c2') | Circle _, Circle _ -> 0 | Ellipse _, Ellipse _ -> 0 | EllipseArc _, EllipseArc _ -> 0 @@ -158,69 +165,78 @@ let internal_diff (d : string) (c : SvgPainter.diff_colors option) (z: string op else bb_comp let draw_difftotal ~prev ~next out_canevas = - let rec rec_draw_difftotal ~prev ~next (idem, theirs, ours, outc) diff_list = - let r s = BoundingBox.reformat ~min_size:20 ~extend:50 (elt_rect s) in - match prev, next with - | p::pl, n::nl -> - let comp = compare p n in - if comp == 0 then - rec_draw_difftotal ~prev:pl ~next:nl ((plot_elt Idem idem p),theirs, ours, outc) diff_list - else if comp < 0 then - rec_draw_difftotal ~prev:pl ~next (idem, (plot_elt Theirs theirs p), ours, outc) ((r p)::diff_list) - else - rec_draw_difftotal ~prev ~next:nl (idem, theirs, (plot_elt Ours ours n), outc) (r n::diff_list) - | p::pl, [] -> - rec_draw_difftotal ~prev:pl ~next (idem, (plot_elt Theirs theirs p), ours, outc) (r p::diff_list) - | [], n::nl -> - rec_draw_difftotal ~prev ~next:nl (idem, theirs, (plot_elt Ours ours n), outc) (r n::diff_list) - |[],[] -> SvgPainter.(add_to theirs (add_to ours (add_to idem outc))), diff_list - in - let new_ctx = SvgPainter.new_from out_canevas in - rec_draw_difftotal ~prev ~next (new_ctx, new_ctx, new_ctx, out_canevas) [] - - let display_diff ~from_ctx ~to_ctx (filename:string list) ~keep = + let rec rec_draw_difftotal ~prev ~next (idem, theirs, ours, outc) + diff_list = + let r s = BoundingBox.reformat ~min_size:20 ~extend:50 (elt_rect s) in + match (prev, next) with + | p :: pl, n :: nl -> + let comp = compare p n in + if comp == 0 then + rec_draw_difftotal ~prev:pl ~next:nl + (plot_elt Idem idem p, theirs, ours, outc) + diff_list + else if comp < 0 then + rec_draw_difftotal ~prev:pl ~next + (idem, plot_elt Theirs theirs p, ours, outc) + (r p :: diff_list) + else + rec_draw_difftotal ~prev ~next:nl + (idem, theirs, plot_elt Ours ours n, outc) + (r n :: diff_list) + | p :: pl, [] -> + rec_draw_difftotal ~prev:pl ~next + (idem, plot_elt Theirs theirs p, ours, outc) + (r p :: diff_list) + | [], n :: nl -> + rec_draw_difftotal ~prev ~next:nl + (idem, theirs, plot_elt Ours ours n, outc) + (r n :: diff_list) + | [], [] -> + ( SvgPainter.(add_to theirs (add_to ours (add_to idem outc))), + diff_list ) + in + let new_ctx = SvgPainter.new_from out_canevas in + rec_draw_difftotal ~prev ~next (new_ctx, new_ctx, new_ctx, out_canevas) [] + + let display_diff ~from_ctx ~to_ctx (filename : string list) ~keep = let prev = List.sort ~cmp:compare from_ctx in let next = List.sort ~cmp:compare to_ctx in - match - draw_difftotal ~prev ~next (SvgPainter.get_color_context c z) - with - | _, [] -> - Lwt.return false + match draw_difftotal ~prev ~next (SvgPainter.get_color_context c z) with + | _, [] -> Lwt.return false | outctx, diff_list -> - let merged_rects = merge_rects diff_list in - let outctx = List.fold_left ~f:draw_bb ~init:outctx merged_rects in - let svg_name = SysAbst.build_tmp_svg_name ~keep "diff_" filename in - let open UnixLabels in - let wait_for_1_s result = - match result with - | WSIGNALED n -> - Printf.printf "signalled with signal %d\n" n ; - Lwt.return svg_name - | WSTOPPED n -> - Printf.printf "stopped with %d\n" n ; - Lwt.return svg_name - | WEXITED err -> ( - match err with - | 127 -> - Printf.printf "Command not found: %s\n" d ; + let merged_rects = merge_rects diff_list in + let outctx = List.fold_left ~f:draw_bb ~init:outctx merged_rects in + let svg_name = SysAbst.build_tmp_svg_name ~keep "diff_" filename in + let open UnixLabels in + let wait_for_1_s result = + match result with + | WSIGNALED n -> + Printf.printf "signalled with signal %d\n" n; + Lwt.return svg_name + | WSTOPPED n -> + Printf.printf "stopped with %d\n" n; Lwt.return svg_name - | 0 -> - let t, u = Lwt.wait () in - let erase_timeout = - Lwt_timeout.create 1 (fun () -> Lwt.wakeup u svg_name) - in - Lwt_timeout.start erase_timeout ; - t - | _ -> - Printf.printf "Errored with code %d\n" err ; - Lwt.return svg_name ) - in - Lwt_io.with_file ~mode:Lwt_io.Output svg_name (fun o -> - Lwt_io.write o @@ SvgPainter.write ~op:false outctx ) - >>= fun _ -> - SysAbst.exec d [|svg_name|] - >>= wait_for_1_s - >>= SysAbst.finalize_tmp_file ~keep - >|= fun _ -> true - end - : Differ ) + | WEXITED err -> ( + match err with + | 127 -> + Printf.printf "Command not found: %s\n" d; + Lwt.return svg_name + | 0 -> + let t, u = Lwt.wait () in + let erase_timeout = + Lwt_timeout.create 1 (fun () -> Lwt.wakeup u svg_name) + in + Lwt_timeout.start erase_timeout; + t + | _ -> + Printf.printf "Errored with code %d\n" err; + Lwt.return svg_name) + in + Lwt_io.with_file ~mode:Lwt_io.Output svg_name (fun o -> + Lwt_io.write o @@ SvgPainter.write ~op:false outctx) + >>= fun _ -> + SysAbst.exec d [| svg_name |] + >>= wait_for_1_s + >>= SysAbst.finalize_tmp_file ~keep + >|= fun _ -> true + end : Differ) diff --git a/plotkicadsch/src/kicadDiff.ml b/plotkicadsch/src/kicadDiff.ml index 454ecc9..b1a2b77 100644 --- a/plotkicadsch/src/kicadDiff.ml +++ b/plotkicadsch/src/kicadDiff.ml @@ -4,27 +4,25 @@ open Kicadsch.Sigs include DiffFs open DiffTool -let doc = function - | TrueFS s -> "file system " ^ s - | GitFS s -> "Git rev " ^ s - +let doc = function TrueFS s -> "file system " ^ s | GitFS s -> "Git rev " ^ s let git_fs commitish = GitFS commitish let true_fs rootname = TrueFS rootname type differ = Internal of string | Image_Diff let fs_mod s r = - let rel_path = Option.bind r (fun rel_path -> - if (String.length rel_path > 1) && - String.equal (String.sub rel_path ~pos:0 ~len:2) "./" then - begin - if String.length rel_path == 2 then - None + let rel_path = + Option.bind r (fun rel_path -> + if + String.length rel_path > 1 + && String.equal (String.sub rel_path ~pos:0 ~len:2) "./" + then + begin if String.length rel_path == 2 then None else Some (String.sub rel_path ~pos:2 ~len:(String.length rel_path - 2)) - end - else - Some rel_path) in + end + else Some rel_path) + in match s with | GitFS s -> GitFs.make s rel_path | TrueFS s -> TrueFs.make s rel_path @@ -32,33 +30,31 @@ let fs_mod s r = let is_suffix ~suffix s = let suff_length = String.length suffix in let s_length = String.length s in - (suff_length < s_length) && - (String.equal (String.sub s ~pos:(String.length s - suff_length) ~len:suff_length) suffix) -;; + suff_length < s_length + && String.equal + (String.sub s ~pos:(String.length s - suff_length) ~len:suff_length) + suffix module FSPainter (S : SchPainter) (F : Simple_FS) : sig val find_schematics : unit -> (string list * string) list Lwt.t - val process_file : S.schContext Lwt.t -> string list -> S.painterContext Lwt.t - val context_from : S.schContext Lwt.t -> S.schContext Lwt.t end = struct - let find_schematics () = F.list_files (is_suffix ~suffix:S.file_extension) let process_file initctx filename = let%lwt init = initctx in - F.get_content filename - >|= S.parse_sheet init >|= S.output_context + F.get_content filename >|= S.parse_sheet init >|= S.output_context let find_libs () = F.list_files (is_suffix ~suffix:"-cache.lib") >|= List.map ~f:fst - let read_libs (initial_ctx:S.schContext) (lib_list: string list list) : S.schContext Lwt.t = + let read_libs (initial_ctx : S.schContext) (lib_list : string list list) : + S.schContext Lwt.t = Lwt_list.fold_left_s (fun c l -> - let%lwt content = F.get_content l in - Lwt.return (S.add_lib content c)) + let%lwt content = F.get_content l in + Lwt.return (S.add_lib content c)) initial_ctx lib_list let context_from from_ctx : S.schContext Lwt.t = @@ -70,96 +66,92 @@ module PathCompare = struct type t = string list * string let rec sl_compare l1 l2 = - match l1, l2 with - | name1::tl1, name2::tl2 -> let res = String.compare name1 name2 in - if res == 0 then - sl_compare tl1 tl2 - else - res - | _h::_t, [] -> 1 - | [], _h::_t -> -1 + match (l1, l2) with + | name1 :: tl1, name2 :: tl2 -> + let res = String.compare name1 name2 in + if res == 0 then sl_compare tl1 tl2 else res + | _h :: _t, [] -> 1 + | [], _h :: _t -> -1 | [], [] -> 0 - let compare (l1, _) (l2, _) = sl_compare l1 l2 + let compare (l1, _) (l2, _) = sl_compare l1 l2 end -module PathSet = Set.Make(PathCompare) + +module PathSet = Set.Make (PathCompare) let merge_lists l1l l2l = - l1l - >>= fun l1 -> - l2l - >|= fun l2 -> + l1l >>= fun l1 -> + l2l >|= fun l2 -> let r = PathSet.empty in let r1 = List.fold_left ~f:(fun s l -> PathSet.add l s) ~init:r l1 in let r2 = List.fold_left ~f:(fun s l -> PathSet.add l s) ~init:r1 l2 in PathSet.elements r2 |> List.rev_map ~f:fst let diff_cmd f t filename = - let diff_cmd = [|"--no-pager"; "diff"; "--word-diff"|] in + let diff_cmd = [| "--no-pager"; "diff"; "--word-diff" |] in match (f, t) with | GitFS fc, GitFS tc -> - ("git", Array.append diff_cmd [|fc; tc; "--"; filename|]) - | TrueFS _, GitFS tc -> - ("git", Array.append diff_cmd [|tc; "--"; filename|]) - | GitFS fc, TrueFS _ -> - ("git", Array.append diff_cmd [|fc; "--"; filename|]) + ("git", Array.append diff_cmd [| fc; tc; "--"; filename |]) + | TrueFS _, GitFS tc -> ("git", Array.append diff_cmd [| tc; "--"; filename |]) + | GitFS fc, TrueFS _ -> ("git", Array.append diff_cmd [| fc; "--"; filename |]) | TrueFS fc, TrueFS tc -> - ( "diff" - , [| fc ^ Filename.dir_sep ^ filename - ; tc ^ Filename.dir_sep ^ filename |] ) + ( "diff", + [| fc ^ Filename.dir_sep ^ filename; tc ^ Filename.dir_sep ^ filename |] + ) -let doit from_fs to_fs file_to_diff differ textdiff libs keep colors zone_color allow_missing_component relative_path = +let doit from_fs to_fs file_to_diff differ textdiff libs keep colors zone_color + allow_missing_component relative_path = let module_d = match differ with - | Image_Diff -> - (module ImageDiff : Differ) - | Internal s -> - InternalDiff.internal_diff s colors zone_color + | Image_Diff -> (module ImageDiff : Differ) + | Internal s -> InternalDiff.internal_diff s colors zone_color in let module D = (val module_d : Differ) in - let module F = (val (fs_mod from_fs relative_path) : Simple_FS) in - let module T = (val (fs_mod to_fs relative_path) : Simple_FS) in + let module F = (val fs_mod from_fs relative_path : Simple_FS) in + let module T = (val fs_mod to_fs relative_path : Simple_FS) in let module FromP = FSPainter (D.S) (F) in let module ToP = FSPainter (D.S) (T) in let file_list = match file_to_diff with | None -> - let from_list = FromP.find_schematics () in - let to_list = ToP.find_schematics () in - merge_lists from_list to_list + let from_list = FromP.find_schematics () in + let to_list = ToP.find_schematics () in + merge_lists from_list to_list | Some filename -> - let filename_l = String.split_on_char ~sep:'/' filename in - Lwt.return [filename_l] + let filename_l = String.split_on_char ~sep:'/' filename in + Lwt.return [ filename_l ] in let preload_libs desc = Lwt_list.fold_left_s (fun c f -> Lwt_stream.fold D.S.add_lib (Lwt_io.lines_of_file f) c) - (D.S.initial_context ~allow_missing_component desc) libs + (D.S.initial_context ~allow_missing_component desc) + libs + in + let from_init_ctx = + FromP.context_from @@ preload_libs (First (doc from_fs)) in - let from_init_ctx = FromP.context_from @@ preload_libs (First (doc from_fs)) in let to_init_ctx = ToP.context_from @@ preload_libs (Second (doc to_fs)) in let compare_one filename = let%lwt from_ctx = FromP.process_file from_init_ctx filename in let%lwt to_ctx = ToP.process_file to_init_ctx filename in match%lwt D.display_diff ~from_ctx ~to_ctx filename ~keep with - | true -> - Lwt.return () + | true -> Lwt.return () | false -> - if textdiff then - let cmd, args = diff_cmd F.label T.label @@ String.concat ~sep:"/" filename in - SysAbst.exec cmd args >|= ignore - else Lwt.return () + if textdiff then + let cmd, args = + diff_cmd F.label T.label @@ String.concat ~sep:"/" filename + in + SysAbst.exec cmd args >|= ignore + else Lwt.return () in let compare_all = file_list >>= Lwt_list.iter_p compare_one in let catch_errors = Lwt.catch (fun _ -> - Lwt_io.printf "%s between %s and %s\n" D.doc (doc F.label) (doc T.label) - >>= fun _ -> compare_all ) + Lwt_io.printf "%s between %s and %s\n" D.doc (doc F.label) (doc T.label) + >>= fun _ -> compare_all) (function - | GitFs.InternalGitError s -> - Lwt_io.printf "Git Exception: %s\n" s - | a -> - Lwt_io.printf "Exception %s\n" (Printexc.to_string a) ) + | GitFs.InternalGitError s -> Lwt_io.printf "Git Exception: %s\n" s + | a -> Lwt_io.printf "Exception %s\n" (Printexc.to_string a)) in Lwt_main.run catch_errors diff --git a/plotkicadsch/src/kicadDiff.mli b/plotkicadsch/src/kicadDiff.mli index f29a149..0699f0e 100644 --- a/plotkicadsch/src/kicadDiff.mli +++ b/plotkicadsch/src/kicadDiff.mli @@ -1,26 +1,35 @@ -(** - schematic diffing module *) +(** schematic diffing module *) (** type of diffing. If internal, specify the application for showing SVGs **) type differ = Internal of string | Image_Diff -(** type of the file system for each leg of the diff *) type t +(** type of the file system for each leg of the diff *) +val git_fs : string -> t (** [git_fs rev] builds a file system tree based on a git revision [rev] *) -val git_fs: string -> t +val true_fs : string -> t (** [true_fs root] builds a fs from the file system [root] directory *) -val true_fs: string -> t +val doc : t -> string (** [doc fs] outputs the doc string of the file system [fs] *) -val doc: t -> string -(** [doit fs_from fs_to filename differ textdiff libs keep colors allow_missing relative_path] - performs the diff of [filename] from [relative_path] if present between [fs_from] and [fs_to] - using strategy [differ] and using common [libs] and [colors] - scheme. If [textdiff], then a text diff is shown when no visual - diff, if [keep] then the diff file isn't removed after *) -val doit: t -> t -> string option -> - differ -> bool -> string list -> bool -> - SvgPainter.diff_colors option -> string option -> bool -> string option -> unit +val doit : + t -> + t -> + string option -> + differ -> + bool -> + string list -> + bool -> + SvgPainter.diff_colors option -> + string option -> + bool -> + string option -> + unit +(** [doit fs_from fs_to filename differ textdiff libs keep colors allow_missing + relative_path] performs the diff of [filename] from [relative_path] if + present between [fs_from] and [fs_to] using strategy [differ] and using + common [libs] and [colors] scheme. If [textdiff], then a text diff is shown + when no visual diff, if [keep] then the diff file isn't removed after *) diff --git a/plotkicadsch/src/listPainter.ml b/plotkicadsch/src/listPainter.ml index c37c99f..09eb9e1 100644 --- a/plotkicadsch/src/listPainter.ml +++ b/plotkicadsch/src/listPainter.ml @@ -19,7 +19,6 @@ type listcanevas = t list module L = struct type t = listcanevas - type painterContext = listcanevas let paint_text ?(kolor = `Black) text (o : orientation) coords s j stl ctx = @@ -36,20 +35,27 @@ module L = struct let paint_ellipse ?(kolor = `Black) ?(fill = `NoColor) center major_radius minor_radius rotation_angle ctx = - Ellipse (kolor, fill, center, major_radius, minor_radius, rotation_angle) :: ctx + Ellipse (kolor, fill, center, major_radius, minor_radius, rotation_angle) + :: ctx let paint_ellipse_arc ?(kolor = `Black) ?(fill = `NoColor) center major_radius minor_radius rotation_angle start_angle end_angle ctx = - EllipseArc (kolor, fill, center, major_radius, minor_radius, rotation_angle, start_angle, end_angle) :: ctx + EllipseArc + ( kolor, + fill, + center, + major_radius, + minor_radius, + rotation_angle, + start_angle, + end_angle ) + :: ctx let paint_arc ?(kolor = `Black) ?(fill = `NoColor) pt_center pt_start pt_stop radius ctx = Arc (kolor, fill, pt_center, pt_start, pt_stop, radius) :: ctx let paint_image corner scale b c = Image (corner, scale, b) :: c - - let get_context () = [] - let set_canevas_size x y c = Format (Coord (x, y)) :: c end diff --git a/plotkicadsch/src/plotgitsch.ml b/plotkicadsch/src/plotgitsch.ml index e08e5b7..9aee42e 100644 --- a/plotkicadsch/src/plotgitsch.ml +++ b/plotkicadsch/src/plotgitsch.ml @@ -2,13 +2,11 @@ open StdLabels open KicadDiff open Cmdliner - -let pp_fs out fs = - Format.fprintf out "%s" (doc fs) +let pp_fs out fs = Format.fprintf out "%s" (doc fs) let get_fs s = - if String.length s > 4 && String.equal (String.sub s ~pos:0 ~len:4) "dir:" then - true_fs (String.sub s ~pos:4 ~len:(String.length s - 4)) + if String.length s > 4 && String.equal (String.sub s ~pos:0 ~len:4) "dir:" + then true_fs (String.sub s ~pos:4 ~len:(String.length s - 4)) else git_fs s let reference = @@ -17,8 +15,8 @@ let reference = let from_ref = let doc = - "reference from which the diff is performed. If it starts with 'dir:' \ - it's a file system dir." + "reference from which the diff is performed. If it starts with 'dir:' it's \ + a file system dir." in let docv = "FROM_REF" in Arg.(value & pos 0 reference (git_fs "HEAD") & info [] ~doc ~docv) @@ -34,10 +32,8 @@ let to_ref = let pp_differ out differ = let s = match differ with - | Internal p -> - "internal with viewer " ^ p - | Image_Diff -> - "external" + | Internal p -> "internal with viewer " ^ p + | Image_Diff -> "external" in Format.fprintf out "%s" s @@ -48,18 +44,24 @@ let differ = let diff_of_file = let doc = "diff only selected file $(docv)." in let docv = "FILENAME" in - Arg.(value & opt (some file) None & info ["f"; "file"] ~doc ~docv) + Arg.(value & opt (some file) None & info [ "f"; "file" ] ~doc ~docv) let internal_diff = let doc = "use an internal diff algorithm and use the $(docv) to display the result." in let docv = "BROWSER" in - let env = Arg.env_var ~doc:"Default viewer for internal diff. Defining this env var forces internal diff." "PLOTGITSCH_VIEWER" in + let env = + Cmd.Env.info + ~doc: + "Default viewer for internal diff. Defining this env var forces \ + internal diff." + "PLOTGITSCH_VIEWER" + in Arg.( value & opt ~vopt:(Internal (SysAbst.default_opener ())) differ Image_Diff - & info ["i"; "internal"] ~env ~doc ~docv) + & info [ "i"; "internal" ] ~env ~doc ~docv) let preloaded_libs = let doc = @@ -67,34 +69,34 @@ let preloaded_libs = can be used several times on command line." in let docv = "LIB" in - Arg.(value & opt_all file [] & info ["l"; "lib"] ~doc ~docv) + Arg.(value & opt_all file [] & info [ "l"; "lib" ] ~doc ~docv) let textual_diff = let doc = "fall back to show a text diff if files are different but generate no \ visual diffs" in - Arg.(value & flag & info ["t"; "textdiff"] ~doc) + Arg.(value & flag & info [ "t"; "textdiff" ] ~doc) let continue_on_missing_component = let doc = - "by default, a missing component aborts the comparison. With this option, a missing component is skipped and the process continues." + "by default, a missing component aborts the comparison. With this option, \ + a missing component is skipped and the process continues." in - Arg.(value & flag & info ["m"; "allow_missing"] ~doc) + Arg.(value & flag & info [ "m"; "allow_missing" ] ~doc) let keep_files = let doc = "by default, the svg diff files are deleted after launching the viewer; \ this option lets the files in place after viewing them. " in - Arg.(value & flag & info ["k"; "keep"] ~doc) + Arg.(value & flag & info [ "k"; "keep" ] ~doc) let pp_colors out c = let open SvgPainter in match c with - | None -> - Format.fprintf out "default colors" - | Some {old_ver; new_ver; fg; bg} -> + | None -> Format.fprintf out "default colors" + | Some { old_ver; new_ver; fg; bg } -> Format.fprintf out "%s:%s:%s:%s" old_ver new_ver fg bg let extract_colors s = @@ -106,16 +108,13 @@ let extract_colors s = in let col_re = Re.Posix.compile_pat cols_exp in match Re.all col_re s with - | [m] -> ( - match Re.Group.all m with - | [|_; o; n; f; b; _|] - | [|_; o; n; f; b|] -> - let e c = "#" ^ c in - Result.Ok (Some {old_ver= e o; new_ver= e n; fg= e f; bg= e b}) - | _ -> - Result.Error (`Msg "wrong colors format") ) - | _ -> - Result.Error (`Msg "wrong colors format") + | [ m ] -> ( + match Re.Group.all m with + | [| _; o; n; f; b; _ |] | [| _; o; n; f; b |] -> + let e c = "#" ^ c in + Result.Ok (Some { old_ver = e o; new_ver = e n; fg = e f; bg = e b }) + | _ -> Result.Error (`Msg "wrong colors format")) + | _ -> Result.Error (`Msg "wrong colors format") let get_colors = let docv = "scheme of colors for diffing" in @@ -123,28 +122,27 @@ let get_colors = let colors = let doc = - "list of colon separated hex RRGGBB codes for colors used for diffing and RRGGBB[AA] code for background e.g. \ - the default colors are FF0000:00FF00:000000:FFFFFFFF" + "list of colon separated hex RRGGBB codes for colors used for diffing and \ + RRGGBB[AA] code for background e.g. the default colors are \ + FF0000:00FF00:000000:FFFFFFFF" in let docv = "old:new:foreground:background" in - let env = Arg.env_var ~doc:"Colors for plotting the diff" "PLOTGITSCH_COLORS" in - - Arg.(value & opt get_colors None & info ["c"; "colors"] ~env ~doc ~docv) + let env = + Cmd.Env.info ~doc:"Colors for plotting the diff" "PLOTGITSCH_COLORS" + in + Arg.(value & opt get_colors None & info [ "c"; "colors" ] ~env ~doc ~docv) let pp_zone_color out c = match c with - | None -> - Format.fprintf out "transparent" - | Some c -> - Format.fprintf out "#%s" c + | None -> Format.fprintf out "transparent" + | Some c -> Format.fprintf out "#%s" c let extract_zone_color s = let col_exp = "(#[0-9a-fA-F]{6})" in let col_re = Re.Posix.compile_pat col_exp in match Re.all col_re s with - | [_] -> Result.Ok (Some s) - | _ -> - Result.Error (`Msg "wrong colors format") + | [ _ ] -> Result.Ok (Some s) + | _ -> Result.Error (`Msg "wrong colors format") let get_zone_color = let docv = "RGB color format" in @@ -155,19 +153,25 @@ let zone_color = "color of the frame around changed zones in hex RGB format, if specified" in let docv = "RGB, eg: #rrggbb" in - let env = Arg.env_var ~doc:"Color for plotting frames around changes" "PLOTGITSCH_CHANGE_COLOR" in - Arg.(value & opt get_zone_color None & info ["z"; "zone"] ~env ~doc ~docv) + let env = + Cmd.Env.info ~doc:"Color for plotting frames around changes" + "PLOTGITSCH_CHANGE_COLOR" + in + Arg.(value & opt get_zone_color None & info [ "z"; "zone" ] ~env ~doc ~docv) let relative_path = let doc = - "force relative path to git working tree root. Detected automatically from current dir by default" in + "force relative path to git working tree root. Detected automatically from \ + current dir by default" + in let docv = "path" in - Arg.(value & opt (some string) None & info ["r"; "relative"] ~doc ~docv) + Arg.(value & opt (some string) None & info [ "r"; "relative" ] ~doc ~docv) let plotgitsch_t = Term.( - const doit $ from_ref $ to_ref $ diff_of_file $ internal_diff - $ textual_diff $ preloaded_libs $ keep_files $ colors $ zone_color $ continue_on_missing_component $ relative_path) + const doit $ from_ref $ to_ref $ diff_of_file $ internal_diff $ textual_diff + $ preloaded_libs $ keep_files $ colors $ zone_color + $ continue_on_missing_component $ relative_path) let info = let doc = @@ -175,10 +179,13 @@ let info = schematic" in let man = - [ `S Manpage.s_bugs - ; `P "Open issues to https://github.com/jnavila/plotkicadsch/issues" ] + [ + `S Manpage.s_bugs; + `P "Open issues to https://github.com/jnavila/plotkicadsch/issues"; + ] in - Term.info "plotgitsch" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits - ~man + Cmd.info "plotgitsch" ~version:"%%VERSION%%" ~doc ~man -let () = Term.exit @@ Term.eval (plotgitsch_t, info) +let command = Cmd.make info plotgitsch_t +let main () = Cmd.eval command +let () = if !Sys.interactive then () else exit (main ()) diff --git a/plotkicadsch/src/plotkicadsch.ml b/plotkicadsch/src/plotkicadsch.ml index 6e4f553..47d0d4c 100644 --- a/plotkicadsch/src/plotkicadsch.ml +++ b/plotkicadsch/src/plotkicadsch.ml @@ -1,4 +1,4 @@ -open Kicadsch.Sigs +open Kicadsch.Sigs let build_outputfilename outdir sch = let open Filename in @@ -11,19 +11,23 @@ let process_files lib_files sch_files outdir = let sch = List.hd sch_files in let schHandler = if String.ends_with ~suffix:".sch" sch then - (module Kicadsch.V5: Kicadsch.Sigs.KicadSchHandler) + (module Kicadsch.V5 : Kicadsch.Sigs.KicadSchHandler) else if String.ends_with ~suffix:".kicad_sch" sch then - (module Kicadsch.V8: Kicadsch.Sigs.KicadSchHandler) - else - failwith ("unknown file extenstion for " ^ sch) in + (module Kicadsch.V8 : Kicadsch.Sigs.KicadSchHandler) + else failwith ("unknown file extenstion for " ^ sch) + in let module SchPainter = (val schHandler) in - let module SvgSchModule = SchPainter.MakeSchPainter(SvgPainter) in + let module SvgSchModule = SchPainter.MakeSchPainter (SvgPainter) in let open SvgSchModule in let initctx = initial_context No_Rev in - let%lwt init = Lwt_list.fold_left_s (fun context lib -> - let%lwt i = Lwt_io.open_file ~mode:Lwt_io.Input lib in - let%lwt content = Lwt_io.read i in - Lwt.return (add_lib content context) ) initctx lib_files in + let%lwt init = + Lwt_list.fold_left_s + (fun context lib -> + let%lwt i = Lwt_io.open_file ~mode:Lwt_io.Input lib in + let%lwt content = Lwt_io.read i in + Lwt.return (add_lib content context)) + initctx lib_files + in let process_file sch_file = let fileout = build_outputfilename outdir sch_file in let%lwt o = Lwt_io.open_file ~mode:Lwt_io.Output fileout in @@ -33,25 +37,25 @@ let process_files lib_files sch_files outdir = let canvas = output_context endcontext in let%lwt () = Lwt_io.write o (SvgPainter.write canvas) in let%lwt () = Lwt_io.close i in - Lwt_io.close o in - Lwt_list.iter_p process_file sch_files - + Lwt_io.close o + in + Lwt_list.iter_p process_file sch_files let () = let files = ref [] in let libs = ref [] in let outpath = ref "" in let speclist = - [ ( "-l" - , Arg.String (fun lib -> libs := lib :: !libs) - , "specify component library" ) - ; ( "-f" - , Arg.String (fun sch -> files := sch :: !files) - , "sch file to process" ) - ; ( "-o" - , Arg.String (fun o -> outpath := o) - , "full path of output directory" ) ] + [ + ( "-l", + Arg.String (fun lib -> libs := lib :: !libs), + "specify component library" ); + ( "-f", + Arg.String (fun sch -> files := sch :: !files), + "sch file to process" ); + ("-o", Arg.String (fun o -> outpath := o), "full path of output directory"); + ] in let usage_msg = "plotkicadsch prints Kicad sch files to svg" in - Arg.parse speclist print_endline usage_msg ; + Arg.parse speclist print_endline usage_msg; Lwt_main.run (process_files !libs !files !outpath) diff --git a/plotkicadsch/src/svgPainter.ml b/plotkicadsch/src/svgPainter.ml index 6d9d358..004d82d 100644 --- a/plotkicadsch/src/svgPainter.ml +++ b/plotkicadsch/src/svgPainter.ml @@ -2,76 +2,64 @@ open Tyxml.Svg open Kicadsch.Defs open Kicadsch.Sigs -type diff_colors = {old_ver: string; new_ver: string; fg: string; bg: string} +type diff_colors = { + old_ver : string; + new_ver : string; + fg : string; + bg : string; +} -type content = [`Polyline | `Text | `Svg | `Rect | `Circle | `Ellipse | `Path | `Image] +type content = + [ `Polyline | `Text | `Svg | `Rect | `Circle | `Ellipse | `Path | `Image ] type dim = int * int -type t = {d: dim; c: content elt list; colors: diff_colors option; zone_color: string option} [@@inline] +type t = { + d : dim; + c : content elt list; + colors : diff_colors option; + zone_color : string option; +} let style_attr_of_style = function - | Italic -> - [a_font_style "italic"] - | Bold -> - [a_font_weight "bold"] - | BoldItalic -> - [a_font_style "italic"; a_font_weight "bold"] - | NoStyle -> - [] + | Italic -> [ a_font_style "italic" ] + | Bold -> [ a_font_weight "bold" ] + | BoldItalic -> [ a_font_style "italic"; a_font_weight "bold" ] + | NoStyle -> [] let anchor_attr_of_justify justif = a_text_anchor - ( match justif with - | J_left -> - `Start - | J_center -> - `Middle - | J_right -> - `End - | J_bottom -> - `End - | J_top -> - `Start ) + (match justif with + | J_left -> `Start + | J_center -> `Middle + | J_right -> `End + | J_bottom -> `End + | J_top -> `Start) -let color_of_kolor k {colors; zone_color; _} = +let color_of_kolor k { colors; zone_color; _ } = let new_ver, old_ver, fg = match colors with - | None -> - ("#00FF00", "#FF0000", "#000000") - | Some {old_ver; new_ver; fg; _} -> - (new_ver, old_ver, fg) + | None -> ("#00FF00", "#FF0000", "#000000") + | Some { old_ver; new_ver; fg; _ } -> (new_ver, old_ver, fg) in let plain c = `Color (c, None) in match k with - | `NoColor -> - `None - | `Black -> - plain "#000000" - | `Red -> - plain "#FF0000" - | `Green -> - plain "#00FF00" - | `Blue -> - plain "#0000CD" - | `Brown -> - plain "#800000" - | `Old -> - plain old_ver - | `New -> - plain new_ver - | `ForeGround -> - plain fg - | `Zone -> - match zone_color with - | None -> `None - | Some c -> plain c + | `NoColor -> `None + | `Black -> plain "#000000" + | `Red -> plain "#FF0000" + | `Green -> plain "#00FF00" + | `Blue -> plain "#0000CD" + | `Brown -> plain "#800000" + | `Old -> plain old_ver + | `New -> plain new_ver + | `ForeGround -> plain fg + | `Zone -> ( match zone_color with None -> `None | Some c -> plain c) (** SVG coord type conversion from int **) let coord_of_int x = (float_of_int x, None) let paint_text ?(kolor = `Black) t (o : orientation) (Coord (x, y)) (Size size) - justif styl ({c; _} as ctxt) = + justif styl ({ c; _ } as ctxt) = let size_in = Printf.sprintf "%f" (float_of_int size) and j = anchor_attr_of_justify justif and s = style_attr_of_style styl @@ -80,95 +68,116 @@ let paint_text ?(kolor = `Black) t (o : orientation) (Coord (x, y)) (Size size) and angle = match o with Orient_H -> 0. | Orient_V -> -90. in let orient = ((angle, None), Some (x_c, y_c)) in let color = color_of_kolor kolor ctxt in - { ctxt with - c= + { + ctxt with + c = text ~a: - ( [ a_x_list [coord_of_int x] - ; a_y_list [coord_of_int y] - ; a_font_size size_in - ; j - ; a_transform [`Rotate orient] - ; a_fill color ] - @ s ) - [pcdata t] - :: c } + ([ + a_x_list [ coord_of_int x ]; + a_y_list [ coord_of_int y ]; + a_font_size size_in; + j; + a_transform [ `Rotate orient ]; + a_fill color; + ] + @ s) + [ pcdata t ] + :: c; + } let paint_line ?(kolor = `Black) ?(width = Size 2) (Coord (x1, y1)) - (Coord (x2, y2)) ({c; _} as ctxt) = + (Coord (x2, y2)) ({ c; _ } as ctxt) = let x1_in = float_of_int x1 in let y1_in = float_of_int y1 in let x2_in = float_of_int x2 in let y2_in = float_of_int y2 in let (Size width) = width in let fwidth = float_of_int width *. 5. in - { ctxt with - c= + { + ctxt with + c = polyline ~a: - [ a_points [(x1_in, y1_in); (x2_in, y2_in)] - ; a_stroke_width (fwidth, Some `Px) - ; a_stroke (color_of_kolor kolor ctxt) ] + [ + a_points [ (x1_in, y1_in); (x2_in, y2_in) ]; + a_stroke_width (fwidth, Some `Px); + a_stroke (color_of_kolor kolor ctxt); + ] [] - :: c } + :: c; + } let paint_rect ?(kolor = `Black) ?(fill = `NoColor) (Coord (x, y)) - (Coord (dim_x, dim_y)) ({c; _} as ctxt) = - { ctxt with - c= + (Coord (dim_x, dim_y)) ({ c; _ } as ctxt) = + { + ctxt with + c = rect ~a: - [ a_x (coord_of_int x) - ; a_y (coord_of_int y) - ; a_width (coord_of_int dim_x) - ; a_height (coord_of_int dim_y) - ; a_fill (color_of_kolor fill ctxt) - ; a_stroke_width (5., Some `Px) - ; a_stroke (color_of_kolor kolor ctxt) ] + [ + a_x (coord_of_int x); + a_y (coord_of_int y); + a_width (coord_of_int dim_x); + a_height (coord_of_int dim_y); + a_fill (color_of_kolor fill ctxt); + a_stroke_width (5., Some `Px); + a_stroke (color_of_kolor kolor ctxt); + ] [] - :: c } + :: c; + } let paint_circle ?(kolor = `Black) ?(fill = `NoColor) (Coord (x, y)) radius - ({c; _} as ctxt) = - { ctxt with - c= + ({ c; _ } as ctxt) = + { + ctxt with + c = circle ~a: - [ a_r (coord_of_int radius) - ; a_cx (coord_of_int x) - ; a_cy (coord_of_int y) - ; a_fill (color_of_kolor fill ctxt) - ; a_stroke_width (10., Some `Px) - ; a_stroke (color_of_kolor kolor ctxt) ] + [ + a_r (coord_of_int radius); + a_cx (coord_of_int x); + a_cy (coord_of_int y); + a_fill (color_of_kolor fill ctxt); + a_stroke_width (10., Some `Px); + a_stroke (color_of_kolor kolor ctxt); + ] [] - :: c } + :: c; + } let paint_ellipse ?(kolor = `Black) ?(fill = `NoColor) (Coord (cx, cy)) - major_radius minor_radius rotation_angle ({c; _} as ctxt) = + major_radius minor_radius rotation_angle ({ c; _ } as ctxt) = let rot = float_of_int rotation_angle in - { ctxt with - c= + { + ctxt with + c = ellipse ~a: - [ a_cx (coord_of_int cx) - ; a_cy (coord_of_int cy) - ; a_rx (coord_of_int major_radius) - ; a_ry (coord_of_int minor_radius) - ; a_transform [`Rotate ((rot, None), Some (float_of_int cx, float_of_int cy))] - ; a_fill (color_of_kolor fill ctxt) - ; a_stroke_width (10., Some `Px) - ; a_stroke (color_of_kolor kolor ctxt) ] + [ + a_cx (coord_of_int cx); + a_cy (coord_of_int cy); + a_rx (coord_of_int major_radius); + a_ry (coord_of_int minor_radius); + a_transform + [ `Rotate ((rot, None), Some (float_of_int cx, float_of_int cy)) ]; + a_fill (color_of_kolor fill ctxt); + a_stroke_width (10., Some `Px); + a_stroke (color_of_kolor kolor ctxt); + ] [] - :: c } + :: c; + } -let paint_ellipse_arc ?(kolor = `Black) ?(fill = `NoColor) - (Coord (cx, cy)) major_radius minor_radius rotation_angle start_angle end_angle - ({c; _} as ctxt) = +let paint_ellipse_arc ?(kolor = `Black) ?(fill = `NoColor) (Coord (cx, cy)) + major_radius minor_radius rotation_angle start_angle end_angle + ({ c; _ } as ctxt) = let rot = float_of_int rotation_angle *. Float.pi /. 180.0 in - let sa = float_of_int start_angle *. Float.pi /. 180.0 in - let ea = float_of_int end_angle *. Float.pi /. 180.0 in - let rx = float_of_int major_radius in - let ry = float_of_int minor_radius in + let sa = float_of_int start_angle *. Float.pi /. 180.0 in + let ea = float_of_int end_angle *. Float.pi /. 180.0 in + let rx = float_of_int major_radius in + let ry = float_of_int minor_radius in let fcx = float_of_int cx in let fcy = float_of_int cy in let cos_rot = cos rot in @@ -176,45 +185,52 @@ let paint_ellipse_arc ?(kolor = `Black) ?(fill = `NoColor) let ellipse_point ang = let x = rx *. cos ang in let y = ry *. sin ang in - (fcx +. x *. cos_rot -. y *. sin_rot, - fcy +. x *. sin_rot +. y *. cos_rot) + ( fcx +. (x *. cos_rot) -. (y *. sin_rot), + fcy +. (x *. sin_rot) +. (y *. cos_rot) ) in let sx, sy = ellipse_point sa in let ex, ey = ellipse_point ea in let diff = end_angle - start_angle in let large_arc = if diff > 180 || diff < -180 then 1 else 0 in let sweep = if diff > 0 then 1 else 0 in - { ctxt with - c= + { + ctxt with + c = path ~a: - [ a_d - (Printf.sprintf "M%d,%d A%d,%d %d %d,%d %d,%d" - (Float.to_int sx) (Float.to_int sy) - major_radius minor_radius rotation_angle - large_arc sweep (Float.to_int ex) (Float.to_int ey)) - ; a_fill (color_of_kolor fill ctxt) - ; a_stroke_width (10., Some `Px) - ; a_stroke (color_of_kolor kolor ctxt) ] + [ + a_d + (Printf.sprintf "M%d,%d A%d,%d %d %d,%d %d,%d" (Float.to_int sx) + (Float.to_int sy) major_radius minor_radius rotation_angle + large_arc sweep (Float.to_int ex) (Float.to_int ey)); + a_fill (color_of_kolor fill ctxt); + a_stroke_width (10., Some `Px); + a_stroke (color_of_kolor kolor ctxt); + ] [] - :: c } + :: c; + } let paint_arc ?(kolor = `Black) ?(fill = `NoColor) (Coord (x, y)) - (Coord (x1, y1)) (Coord (x2, y2)) radius ({c; _} as ctxt) = + (Coord (x1, y1)) (Coord (x2, y2)) radius ({ c; _ } as ctxt) = (* not sure how this thing behaves. This setup seems to work *) let sweepflag = if (x1 - x) * (y2 - y) > (x2 - x) * (y1 - y) then 1 else 0 in - { ctxt with - c= + { + ctxt with + c = path ~a: - [ a_d + [ + a_d (Printf.sprintf "M%d,%d A%d,%d 0 0,%d %d,%d" x1 y1 radius radius - sweepflag x2 y2) - ; a_fill (color_of_kolor fill ctxt) - ; a_stroke_width (10., Some `Px) - ; a_stroke (color_of_kolor kolor ctxt) ] + sweepflag x2 y2); + a_fill (color_of_kolor fill ctxt); + a_stroke_width (10., Some `Px); + a_stroke (color_of_kolor kolor ctxt); + ] [] - :: c } + :: c; + } let get_png_dims b = if Buffer.sub b 1 3 = "PNG" then @@ -231,83 +247,93 @@ let get_png_dims b = exception Base64Exception of string -let paint_image (Coord (x, y)) scale b ({c; _} as ctxt) = +let paint_image (Coord (x, y)) scale b ({ c; _ } as ctxt) = let s = scale /. 0.3 in let w, h = get_png_dims b in match Base64.encode (Buffer.contents b) with | Ok outstring -> - { ctxt with - c= + { + ctxt with + c = image ~a: - [ a_x (float x -. (float (w / 2) *. s), None) - ; a_y (float y -. (float (h / 2) *. s), None) - ; a_height (float h *. s, None) - ; a_width (float w *. s, None) - ; a_xlink_href @@ "data:image/png;base64," ^ outstring ] + [ + a_x (float x -. (float (w / 2) *. s), None); + a_y (float y -. (float (h / 2) *. s), None); + a_height (float h *. s, None); + a_width (float w *. s, None); + a_xlink_href @@ "data:image/png;base64," ^ outstring; + ] [] - :: c } - | Error (`Msg err) -> - raise (Base64Exception err) + :: c; + } + | Error (`Msg err) -> raise (Base64Exception err) -let paint_zone (Coord (x, y)) (Coord (dim_x, dim_y)) ({c; _} as ctxt) = +let paint_zone (Coord (x, y)) (Coord (dim_x, dim_y)) ({ c; _ } as ctxt) = let fill_color = color_of_kolor `Zone ctxt in - let render = if fill_color == `None then - [a_style "fill-opacity: 0;"] - else - [ a_fill (color_of_kolor `Zone ctxt) - ; a_style "fill-opacity: 0.1;" - ] in - - { ctxt with - c= + let render = + if fill_color == `None then [ a_style "fill-opacity: 0;" ] + else [ a_fill (color_of_kolor `Zone ctxt); a_style "fill-opacity: 0.1;" ] + in + { + ctxt with + c = rect - ~a:( - [ a_x (coord_of_int x) - ; a_y (coord_of_int y) - ; a_width (coord_of_int dim_x) - ; a_height (coord_of_int dim_y) - ; a_stroke_width (5., Some `Px) - ; a_class ["zone"] - ] @ render) + ~a: + ([ + a_x (coord_of_int x); + a_y (coord_of_int y); + a_width (coord_of_int dim_x); + a_height (coord_of_int dim_y); + a_stroke_width (5., Some `Px); + a_class [ "zone" ]; + ] + @ render) [] - :: c } - + :: c; + } -let get_context () = {d= (0, 0); c= []; colors= None; zone_color=None} +let get_context () = { d = (0, 0); c = []; colors = None; zone_color = None } -let get_color_context colors zone_color = {d= (0, 0); c= []; colors; zone_color} +let get_color_context colors zone_color = + { d = (0, 0); c = []; colors; zone_color } -let new_from {colors; zone_color; _} = {d= (0, 0); c= []; colors; zone_color} +let new_from { colors; zone_color; _ } = + { d = (0, 0); c = []; colors; zone_color } -let add_to {d=(x2, y2);c=c1; _} {d=(x1, y1); c=c2; colors; zone_color} = +let add_to { d = x2, y2; c = c1; _ } { d = x1, y1; c = c2; colors; zone_color } + = let c = List.rev_append c1 c2 in - {d=((max x1 x2), (max y1 y2)); c; colors; zone_color} + { d = (max x1 x2, max y1 y2); c; colors; zone_color } -let set_canevas_size x y ctxt = {ctxt with d= (x, y)} +let set_canevas_size x y ctxt = { ctxt with d = (x, y) } -let write ?(op = true) {d= x, y; c; colors; _} = +let write ?(op = true) { d = x, y; c; colors; _ } = let fx = float x in let fy = float y in let o = if op then 1.0 else 0.8 in - let bg = match colors with None -> "#FFFFFF" | Some {bg; _} -> bg in + let bg = match colors with None -> "#FFFFFF" | Some { bg; _ } -> bg in let opacity = a_style @@ Printf.sprintf "stroke-opacity:%f;fill-opacity:%f;" o o in let svg_doc = svg ~a: - [ a_width (fx *. 0.00254, Some `Cm) - ; a_height (fy *. 0.00254, Some `Cm) - ; a_viewBox (0., 0., float x, float y) - ; a_font_family "Verdana, sans-serif" - ; opacity ] + [ + a_width (fx *. 0.00254, Some `Cm); + a_height (fy *. 0.00254, Some `Cm); + a_viewBox (0., 0., float x, float y); + a_font_family "Verdana, sans-serif"; + opacity; + ] @@ rect ~a: - [ a_fill (`Color (bg, None)) - ; a_width (coord_of_int x) - ; a_height (coord_of_int y) - ; a_style "stroke-opacity:1.0;fill-opacity:1.0;" ] + [ + a_fill (`Color (bg, None)); + a_width (coord_of_int x); + a_height (coord_of_int y); + a_style "stroke-opacity:1.0;fill-opacity:1.0;"; + ] [] :: c in diff --git a/plotkicadsch/src/sysAbst.ml b/plotkicadsch/src/sysAbst.ml index c3c7b52..d23d40a 100644 --- a/plotkicadsch/src/sysAbst.ml +++ b/plotkicadsch/src/sysAbst.ml @@ -7,40 +7,35 @@ let process_output_to_string command = let res = ref "" in let rec process_otl_aux () = let e = input_line chan in - res := e ^ !res ; + res := e ^ !res; process_otl_aux () in try process_otl_aux () with End_of_file -> let stat = UnixLabels.close_process_in chan in (!res, stat) -;; let cmd_output command = let l, _ = process_output_to_string command in l -;; let launch_on_windows command = let _, s = process_output_to_string ("start " ^ command) in Lwt.return s -;; let detect_os () : os = if Sys.win32 then Windows else if Sys.cygwin then Cygwin else - let ((in_ch, _, _) as uname) = UnixLabels.open_process_full "uname" ~env:[| |] in + let ((in_ch, _, _) as uname) = + UnixLabels.open_process_full "uname" ~env:[||] + in let os = input_line in_ch in - ignore (UnixLabels.close_process_full uname) ; + ignore (UnixLabels.close_process_full uname); match os with - | "Darwin" -> - MacOS - | "Linux" -> - Linux - | _ -> - failwith "unknown operating system" -;; + | "Darwin" -> MacOS + | "Linux" -> Linux + | _ -> failwith "unknown operating system" let windows_quote s = let open Re in @@ -48,32 +43,27 @@ let windows_quote s = (Posix.compile_pat {|\^|&|\||\(|<|>|}) ~f:(fun ss -> "^" ^ Group.get ss 0) s -;; let exec c a = match detect_os () with - | MacOS | Linux -> - Lwt_process.exec ("", Array.append [|c|] a) + | MacOS | Linux -> Lwt_process.exec ("", Array.append [| c |] a) | Cygwin | Windows -> launch_on_windows @@ Array.fold_left ~f:(fun f g -> f ^ " " ^ windows_quote g) ~init:c a -;; let pread c a = match detect_os () with | MacOS | Linux -> - Lwt_process.pread ~stderr:`Dev_null ("", Array.append [|c|] a) + Lwt_process.pread ~stderr:`Dev_null ("", Array.append [| c |] a) | Cygwin | Windows -> Lwt.return @@ cmd_output (Array.fold_left ~f:(fun f g -> f ^ " " ^ windows_quote g) ~init:c a) -;; let rec last_exn = function - | [e] -> e - | _::tl -> last_exn tl + | [ e ] -> e + | _ :: tl -> last_exn tl | [] -> raise Not_found -;; let build_tmp_svg_name ~keep aprefix aschpath = let aschname = last_exn aschpath in @@ -82,28 +72,18 @@ let build_tmp_svg_name ~keep aprefix aschpath = in if keep then root_prefix ^ ".svg" else Stdlib.Filename.temp_file root_prefix ".svg" -;; let finalize_tmp_file fnl ~keep = match detect_os () with | MacOS | Linux -> ( - try%lwt - if not keep then - Lwt_unix.unlink fnl - else - Lwt.return_unit - with _ -> Lwt.return_unit ) - | Cygwin | Windows -> - Lwt.return_unit -;; + try%lwt if not keep then Lwt_unix.unlink fnl else Lwt.return_unit + with _ -> Lwt.return_unit) + | Cygwin | Windows -> Lwt.return_unit let default_opener () = match detect_os () with - | Linux -> - "xdg-open" - | MacOS -> - "open" - | Cygwin | Windows -> - "" + | Linux -> "xdg-open" + | MacOS -> "open" + | Cygwin | Windows -> "" (* we already use "start" in exec *) diff --git a/plotkicadsch/src/sysAbst.mli b/plotkicadsch/src/sysAbst.mli index 7046025..2a57e4f 100644 --- a/plotkicadsch/src/sysAbst.mli +++ b/plotkicadsch/src/sysAbst.mli @@ -1,10 +1,7 @@ val pread : string -> string array -> string Lwt.t - val exec : string -> string array -> Unix.process_status Lwt.t (* the two following function are meant to be used together *) val build_tmp_svg_name : keep:bool -> string -> string list -> string - val finalize_tmp_file : string -> keep:bool -> unit Lwt.t - val default_opener : unit -> string diff --git a/plotkicadsch/src/trueFs.ml b/plotkicadsch/src/trueFs.ml index 426c9d8..6b139ad 100644 --- a/plotkicadsch/src/trueFs.ml +++ b/plotkicadsch/src/trueFs.ml @@ -3,58 +3,60 @@ open Lwt.Infix open DiffFs let make rootname relative = - ( module struct - + (module struct let lstrip c s = let rec find_non_c c s n = - if s.[n] != c then - String.sub ~pos:n ~len:(String.length s - n) s - else - find_non_c c s (n+1) + if s.[n] != c then String.sub ~pos:n ~len:(String.length s - n) s + else find_non_c c s (n + 1) in find_non_c c s 0 - let rootname = (lstrip '/' rootname) ^ (match relative with - | None -> "" - | Some p -> "/" ^ (lstrip '/' p)) + let rootname = + lstrip '/' rootname + ^ match relative with None -> "" | Some p -> "/" ^ lstrip '/' p let label = TrueFS rootname - - let rootlength = (String.length rootname) + 1 + let rootlength = String.length rootname + 1 let get_content filename = - let filepath = (String.concat ~sep:Filename.dir_sep (rootname::filename)) in - try%lwt - Lwt_io.with_file ~mode:Lwt_io.input filepath Lwt_io.read - with - _ -> Lwt.return "" + let filepath = + String.concat ~sep:Filename.dir_sep (rootname :: filename) + in + try%lwt Lwt_io.with_file ~mode:Lwt_io.input filepath Lwt_io.read + with _ -> Lwt.return "" let hash_file filename = - get_content filename - >|= fun c -> + get_content filename >|= fun c -> let blob_content = Printf.sprintf "blob %d\000" (String.length c) ^ c in (filename, Sha1.to_hex (Sha1.string blob_content)) let dir_contents dir pattern = let rec loop result = function - | f::fs when Sys.is_directory f -> - let contents =Sys.readdir f - |> Array.to_list - |> List.map ~f:(Filename.concat f) - |> List.append fs - in loop result (List.rev_append fs contents) - | f::fs when pattern f -> loop (f::result) fs - | _::fs -> loop result fs - | [] -> result + | f :: fs when Sys.is_directory f -> + let contents = + Sys.readdir f |> Array.to_list + |> List.map ~f:(Filename.concat f) + |> List.append fs + in + loop result (List.rev_append fs contents) + | f :: fs when pattern f -> loop (f :: result) fs + | _ :: fs -> loop result fs + | [] -> result in - loop [] [dir] - - let list_files pattern = - let list = dir_contents rootname pattern in - let file_list = Lwt_list.map_s (fun filename -> - let filename = String.sub filename ~pos:rootlength ~len:(String.length filename - rootlength) in - let file_path = String.split_on_char ~sep:'/' filename in - hash_file file_path) list in - file_list - end - : Simple_FS ) + loop [] [ dir ] + + let list_files pattern = + let list = dir_contents rootname pattern in + let file_list = + Lwt_list.map_s + (fun filename -> + let filename = + String.sub filename ~pos:rootlength + ~len:(String.length filename - rootlength) + in + let file_path = String.split_on_char ~sep:'/' filename in + hash_file file_path) + list + in + file_list + end : Simple_FS) diff --git a/sexp_decode/.ocamlformat b/sexp_decode/.ocamlformat deleted file mode 100644 index e69de29..0000000 diff --git a/sexp_decode/sexp_decode.ml b/sexp_decode/sexp_decode.ml index 4cc05ea..e5cd703 100644 --- a/sexp_decode/sexp_decode.ml +++ b/sexp_decode/sexp_decode.ml @@ -1,8 +1,6 @@ -(** - Copyright © Inria 2022 +(** Copyright © Inria 2022 - @author Benoît Montagu -*) + @author Benoît Montagu *) include Sexp_decode_intf @@ -12,7 +10,7 @@ module Make (X : SEXP) : S with type sexp := X.t = struct type 'a decode_res = Err of sexp | GenErr | SomeRes of 'a type 'a decoder = state -> (state * 'a) decode_res - let run_with_result (decode: 'a decoder) (sexp: sexp) : ('a, sexp) result = + let run_with_result (decode : 'a decoder) (sexp : sexp) : ('a, sexp) result = match decode [ [ sexp ] ] with | GenErr -> Error sexp | Err s -> Error s @@ -22,7 +20,7 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let run_list (decode : 'a decoder) (sexps : sexp list) : 'a option = match decode [ sexps ] with - | GenErr| Err _ | SomeRes((_ :: _) :: _, _) -> None + | GenErr | Err _ | SomeRes ((_ :: _) :: _, _) -> None | SomeRes ([], _) -> assert false | SomeRes ([] :: _, v) -> Some v @@ -31,13 +29,12 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let return (v : 'a) : 'a decoder = fun rem -> SomeRes (rem, v) let const = return - let%test _ = run_list (return 42) [] = Some 42 let%test _ = run_list (return 42) [ Atom "foo" ] = None let%test _ = run (return 42) (Atom "foo") = None let error : 'a decoder = function - | (state::_)::_ -> Err state + | (state :: _) :: _ -> Err state | _ -> GenErr let%test _ = run_list error [] = None @@ -46,7 +43,9 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let fail_default (default : 'a) (decode : 'b decoder) : 'a decoder = fun state -> - match decode state with SomeRes ((state::_)::_,_) -> Err state | SomeRes _ | GenErr | Err _ -> SomeRes (state, default) + match decode state with + | SomeRes ((state :: _) :: _, _) -> Err state + | SomeRes _ | GenErr | Err _ -> SomeRes (state, default) let fail (decode : 'a decoder) : unit decoder = fail_default () decode @@ -54,29 +53,29 @@ module Make (X : SEXP) : S with type sexp := X.t = struct fun state -> match decode state with | SomeRes (_, v) -> SomeRes (state, v) - | GenErr | Err _ as err -> err + | (GenErr | Err _) as err -> err let map (f : 'a -> 'b) (decode : 'a decoder) : 'b decoder = - fun state -> + fun state -> match decode state with | SomeRes (s, v) -> SomeRes (s, f v) - | GenErr | Err _ as err -> err + | (GenErr | Err _) as err -> err let flip_map decode f = map f decode let ( >>| ) = flip_map let ( let+ ) = flip_map - let%test _ = run_list (return 42 >>| ( + ) 1) [] = Some 43 let%test _ = run_list (return 42 >>| ( + ) 1) [ Atom "foo" ] = None let%test _ = run (return 42 >>| ( + ) 1) (Atom "foo") = None let bind (decode : 'a decoder) (f : 'a -> 'b decoder) : 'b decoder = fun state -> - match decode state with GenErr | Err _ as err -> err | SomeRes (state, res) -> f res state + match decode state with + | (GenErr | Err _) as err -> err + | SomeRes (state, res) -> f res state let ( >>= ) = bind let ( let* ) = bind - let%test _ = run_list (return 42 >>= fun n -> return (n + 1)) [] = Some 43 let%test _ = @@ -86,12 +85,12 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let seq (decode1 : 'a decoder) (decode2 : 'b decoder) : 'b decoder = fun state -> - match decode1 state with GenErr | Err _ as err -> err | SomeRes (state, _) -> decode2 state + match decode1 state with + | (GenErr | Err _) as err -> err + | SomeRes (state, _) -> decode2 state let ( >>> ) = seq - let%test _ = run_list (return 42 >>> return 43) [] = Some 43 - let drop (decode : 'a decoder) : unit decoder = decode >>> return () let ( <<< ) (decode1 : 'a decoder) (decode2 : 'b decoder) : 'a decoder = @@ -103,7 +102,9 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let or_else (decode1 : 'a decoder) (decode2 : 'a decoder) : 'a decoder = fun state -> - match decode1 state with SomeRes _ as ok -> ok | GenErr | Err _ -> decode2 state + match decode1 state with + | SomeRes _ as ok -> ok + | GenErr | Err _ -> decode2 state let ( |+> ) = or_else @@ -113,7 +114,9 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let or_else_delayed (decode1 : 'a decoder) (decode2 : unit -> 'a decoder) : 'a decoder = fun state -> - match decode1 state with SomeRes _ as ok -> ok | GenErr | Err _ -> decode2 () state + match decode1 state with + | SomeRes _ as ok -> ok + | GenErr | Err _ -> decode2 () state let ( |+>> ) = or_else_delayed @@ -124,7 +127,6 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let ( <*> ) = pair let tuple2 = pair - let%test _ = run_list (return 42 <*> return 43) [] = Some (42, 43) let tuple3 (d1 : 'a1 decoder) (d2 : 'a2 decoder) (d3 : 'a3 decoder) : @@ -191,7 +193,7 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let raw : sexp decoder = function | [] -> assert false - | [] :: ((next::_)::_) -> Err next + | [] :: (next :: _) :: _ -> Err next | [] :: _ -> GenErr | (v :: vs) :: next -> SomeRes (vs :: next, v) @@ -205,7 +207,7 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let skip : unit decoder = function | [] -> assert false - | [] :: ((next::_)::_) -> Err next + | [] :: (next :: _) :: _ -> Err next | [] :: _ -> GenErr | (_ :: vs) :: next -> SomeRes (vs :: next, ()) @@ -229,9 +231,9 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let atom : string decoder = function | [] -> assert false - | [] :: ((next::_)::_) -> Err next + | [] :: (next :: _) :: _ -> Err next | [] :: _ -> GenErr - | ((List _ as err_point):: _) :: _ -> Err err_point + | ((List _ as err_point) :: _) :: _ -> Err err_point | (Atom s :: vs) :: next -> SomeRes (vs :: next, s) let%test _ = run atom (Atom "foo") = Some "foo" @@ -259,8 +261,8 @@ module Make (X : SEXP) : S with type sexp := X.t = struct let enter : unit decoder = function | [] -> assert false - | ((Atom _ as err_point):: _) :: _ -> Err err_point - | [] :: ((next::_)::_) -> Err next + | ((Atom _ as err_point) :: _) :: _ -> Err err_point + | [] :: (next :: _) :: _ -> Err next | [] :: _ -> GenErr | (List l :: vs) :: next -> SomeRes (l :: vs :: next, ()) @@ -270,7 +272,6 @@ module Make (X : SEXP) : S with type sexp := X.t = struct | [] :: next -> SomeRes (next, ()) let group (decode : 'a decoder) = enter >>> decode <<< exit - let%test _ = run (group (return ())) (List []) = Some () let%test _ = run (group (return ())) (List [ Atom "foo" ]) = None let%test _ = run (group atom) (List [ Atom "foo" ]) = Some "foo" @@ -291,7 +292,6 @@ module Make (X : SEXP) : S with type sexp := X.t = struct if p v then return v else error let tag s : string decoder = filter (String.equal s) atom - let%test _ = run (tag "A") (Atom "A") = Some "A" let%test _ = run (tag "A") (Atom "B") = None @@ -402,7 +402,6 @@ module Make (X : SEXP) : S with type sexp := X.t = struct decode >>> repeat ~until decode let skip_all : unit decoder = repeat ~until:no_more skip - let%test _ = run_list skip_all [ Atom "A"; List []; Atom "B" ] = Some () let%test _ = run_list skip_all [] = Some () @@ -516,7 +515,6 @@ module Make (X : SEXP) : S with type sexp := X.t = struct run (list (tag "A")) (List [ Atom "A"; Atom "A" ]) = Some [ "A"; "A" ] let%test _ = run (list (tag "A")) (List [ Atom "A"; Atom "B" ]) = None - let field name (decode : 'a decoder) : 'a decoder = group (tag name >>> decode) let%test _ = diff --git a/sexp_decode/sexp_decode.mli b/sexp_decode/sexp_decode.mli index 8541ec3..366c6de 100644 --- a/sexp_decode/sexp_decode.mli +++ b/sexp_decode/sexp_decode.mli @@ -1,10 +1,9 @@ -(** A library of monadic combinators for decoding S-expressions (as - defined in the [Csexp] library) into structured data. +(** A library of monadic combinators for decoding S-expressions (as defined in + the [Csexp] library) into structured data. @see Copyright © Inria 2022 - @author Benoît Montagu -*) + @author Benoît Montagu *) include Sexp_decode_intf.INTF diff --git a/sexp_decode/sexp_decode_intf.ml b/sexp_decode/sexp_decode_intf.ml index 38b1bd8..b8af402 100644 --- a/sexp_decode/sexp_decode_intf.ml +++ b/sexp_decode/sexp_decode_intf.ml @@ -1,10 +1,8 @@ -(** - Signatures for the whole library +(** Signatures for the whole library - Copyright © Inria 2022 + Copyright © Inria 2022 - @author Benoît Montagu -*) + @author Benoît Montagu *) (** Module type of S-expressions *) module type SEXP = sig @@ -17,25 +15,25 @@ module type S = sig type 'a decoder (** Type of decoders: a decoder of type ['a decoder] decodes a list of - S-expressions into a value of type ['a]. A decoder contains a state - of which S-expression is next available, and which ones should be - processed later. *) + S-expressions into a value of type ['a]. A decoder contains a state of + which S-expression is next available, and which ones should be processed + later. *) - val run_with_result: 'a decoder -> sexp -> ('a, sexp) result + val run_with_result : 'a decoder -> sexp -> ('a, sexp) result val run_list : 'a decoder -> sexp list -> 'a option (** [run_list d l] tries to decode the list of S-expression [l] into a - structure value, using the decoder [d] *) + structure value, using the decoder [d] *) val run : 'a decoder -> sexp -> 'a option - (** [run d s] tries to decode the S-expression [s] into a structure - value, using the decoder [d]. This is the same as [run_list d [s]] *) + (** [run d s] tries to decode the S-expression [s] into a structure value, + using the decoder [d]. This is the same as [run_list d [s]] *) (** {1 Monadic combinators} *) val return : 'a -> 'a decoder - (** [return v] is the constant decoder: it always returns the value - [v]. It does not consume any part of the input. *) + (** [return v] is the constant decoder: it always returns the value [v]. It + does not consume any part of the input. *) val const : 'a -> 'a decoder (** [const v] is the same as [return v] *) @@ -44,19 +42,19 @@ module type S = sig (** [error] is the decoder that always fails *) val fail_default : 'a -> 'b decoder -> 'a decoder - (** [fail_default v d] fails when [d] succeeds, and succeeds by - returning [v] when [d] fails *) + (** [fail_default v d] fails when [d] succeeds, and succeeds by returning [v] + when [d] fails *) val fail : 'a decoder -> unit decoder (** [fail d] is the same as [fail_default () d] *) val try_ : 'a decoder -> 'a decoder - (** [try_ d] succeeds iff [d] succeeds and returns the value - produced by [d]. However, the state remains unchanged. *) + (** [try_ d] succeeds iff [d] succeeds and returns the value produced by [d]. + However, the state remains unchanged. *) val map : ('a -> 'b) -> 'a decoder -> 'b decoder - (** [map f d] succeeds and returns [f x] when [d] succeeds and returns - [x]. When [d] fails, [map f d] fails as well. *) + (** [map f d] succeeds and returns [f x] when [d] succeeds and returns [x]. + When [d] fails, [map f d] fails as well. *) val ( >>| ) : 'a decoder -> ('a -> 'b) -> 'b decoder (** [d >>| f] is the same as [map f d] *) @@ -65,9 +63,8 @@ module type S = sig (** [let+ x = d in t] is the same as [map (fun x -> t) d] *) val bind : 'a decoder -> ('a -> 'b decoder) -> 'b decoder - (** Monadic bind: [bind d f] first decodes using [d], and if [d] - succeeds with a value [v], then decoding is performed using [f v]. - *) + (** Monadic bind: [bind d f] first decodes using [d], and if [d] succeeds with + a value [v], then decoding is performed using [f v]. *) val ( >>= ) : 'a decoder -> ('a -> 'b decoder) -> 'b decoder (** [d >>= f] is the same as [bind d f] *) @@ -76,9 +73,9 @@ module type S = sig (** [let* x = d in t] is the same as [bind d (fun x -> t)] *) val seq : 'a decoder -> 'b decoder -> 'b decoder - (** [seq d1 d2] is the decoder that first decodes with [d1], drops its - result, and decodes using [d2]. Fails when [d1] fails, and when - [d1] succeeds and [d2] fails. *) + (** [seq d1 d2] is the decoder that first decodes with [d1], drops its result, + and decodes using [d2]. Fails when [d1] fails, and when [d1] succeeds and + [d2] fails. *) val ( >>> ) : 'a decoder -> 'b decoder -> 'b decoder (** [d1 >>> d2] is the same as [seq d1 d2] *) @@ -87,25 +84,24 @@ module type S = sig (** [drop d] is the same as [map (fun _ -> return ()) d] *) val ( <<< ) : 'a decoder -> 'b decoder -> 'a decoder - (** Same as [seq d1 d2], but keeps the result of [d1] and drops the - result of [d2] *) + (** Same as [seq d1 d2], but keeps the result of [d1] and drops the result of + [d2] *) val or_else : 'a decoder -> 'a decoder -> 'a decoder - (** [or_else d1 d2] first decodes with [d1], and stops there if [d1] - succeeds. If [d1] fails, then decoding with [d2] is performed. *) + (** [or_else d1 d2] first decodes with [d1], and stops there if [d1] succeeds. + If [d1] fails, then decoding with [d2] is performed. *) val ( |+> ) : 'a decoder -> 'a decoder -> 'a decoder (** [d1 |+> d2] is the same as [or_else d1 d2] *) val first : 'a decoder list -> 'a decoder - (** [first [d1; ... ; dn]] selects the first decoder [di] that - succeeds *) + (** [first [d1; ... ; dn]] selects the first decoder [di] that succeeds *) val or_else_delayed : 'a decoder -> (unit -> 'a decoder) -> 'a decoder - (** [or_else_delayed d1 (fun () -> d2)] behaves the same as [or_else - d1 d2], with the difference that the evaluation of the second - operand is delayed. This is useful when defining recursive - decoders, when [d2] refers to a recursive call. *) + (** [or_else_delayed d1 (fun () -> d2)] behaves the same as [or_else d1 d2], + with the difference that the evaluation of the second operand is delayed. + This is useful when defining recursive decoders, when [d2] refers to a + recursive call. *) val ( |+>> ) : 'a decoder -> (unit -> 'a decoder) -> 'a decoder (** [d |+>> f] is the same as [or_else_delayed d f] *) @@ -113,145 +109,144 @@ module type S = sig (** {1 Basic decoders} *) val raw : sexp decoder - (** [raw] accepts [Atom s] and [List l], and returns that - S-expression. Consumes one element. *) + (** [raw] accepts [Atom s] and [List l], and returns that S-expression. + Consumes one element. *) val skip : unit decoder - (** [skip] accepts [Atom s] and [List l], and returns [()]. Consumes - one element. *) + (** [skip] accepts [Atom s] and [List l], and returns [()]. Consumes one + element. *) val skip_all : unit decoder - (** [skip_all] accepts everything until no element is available - anymore. Consomes 0 or more elements. *) + (** [skip_all] accepts everything until no element is available anymore. + Consomes 0 or more elements. *) val atom : string decoder (** [atom] accepts [Atom s], and returns [s]. Consumes one element. *) val no_more : unit decoder - (** [no_more] returns [()] when there is no more S-expression - available. Consumones nothing. *) + (** [no_more] returns [()] when there is no more S-expression available. + Consumones nothing. *) val bool : bool decoder (** [bool] accepts [Atom "true"] by returning [true], and accepts - [Atom "false"] by returning [false]. Consumes one element. *) + [Atom "false"] by returning [false]. Consumes one element. *) val int : int decoder - (** [int] accepts [Atom s] by returning the integer [n] denoted by the - string [s]. Consumes one element. *) + (** [int] accepts [Atom s] by returning the integer [n] denoted by the string + [s]. Consumes one element. *) val float : float decoder - (** [int] accepts [Atom s] by returning the float [f] denoted by the - string [s]. Consumes one element. *) + (** [int] accepts [Atom s] by returning the float [f] denoted by the string + [s]. Consumes one element. *) val string : ?escaped:bool -> string decoder - (** [string ~escaped] accepts [Atom s] and returns [s] when - [escaped=false], or the unescaped interpretation of [s] when - [escaped=true]. Default: [escaped=false]. Consumes one element. *) + (** [string ~escaped] accepts [Atom s] and returns [s] when [escaped=false], + or the unescaped interpretation of [s] when [escaped=true]. Default: + [escaped=false]. Consumes one element. *) val tag : string -> string decoder - (** [tag name] accepts [Atom s] when [s = name], and returns [s]. - Consumes one element. *) + (** [tag name] accepts [Atom s] when [s = name], and returns [s]. Consumes one + element. *) (** {1 Combinators for compound data} *) (** {2 Basic combinators} *) val peek : 'a decoder -> 'a option decoder - (** [peek d] returns [Some v] if [d] succeeds with [v], or returns - [None] otherwise, and restores the state as it was before calling - [d]. Consumes nothing. *) + (** [peek d] returns [Some v] if [d] succeeds with [v], or returns [None] + otherwise, and restores the state as it was before calling [d]. Consumes + nothing. *) val group : 'a decoder -> 'a decoder - (** [group d] accepts [List l] when [d] accepts [l], and returns the - result provided by [d]. Consumes one element. *) + (** [group d] accepts [List l] when [d] accepts [l], and returns the result + provided by [d]. Consumes one element. *) val field : string -> 'a decoder -> 'a decoder - (** [field name d] recognizes [List [Atom s; e1; ... ; en]] where - [s = name] and [d] recognizes [[e1; ...; en]]. Consumes one element. *) + (** [field name d] recognizes [List [Atom s; e1; ... ; en]] where [s = name] + and [d] recognizes [[e1; ...; en]]. Consumes one element. *) val variant : (string * 'a decoder) list -> 'a decoder (** [variant cases] accepts [List [Atom name; e1; ...; en]] such that - [(name, d)] is found in the association list [cases], and [d] - accepts [[e1; ...; en]]. Only the first match for [name] is tried: - the other ones are ignored. *) + [(name, d)] is found in the association list [cases], and [d] accepts + [[e1; ...; en]]. Only the first match for [name] is tried: the other ones + are ignored. *) val record : default:'a -> (string * ('a -> 'a) decoder) list -> 'a decoder (** [record ~default [(name1, d1); ...; (namen, dn)]] recognizes - [List [List (Atom name'1 :: l'1); ...; List (Atom name'k :: l'k)]] - where for every [name'i], there exists [j] such that [name'i = namej], - and [l'i] is accepted by [dj]. In case of success, the output value is - [fjn ( ... (fj1 default) ...)] where the [fjk] are the values produced - by [djk]. + [List [List (Atom name'1 :: l'1); ...; List (Atom name'k :: l'k)]] where + for every [name'i], there exists [j] such that [name'i = namej], and [l'i] + is accepted by [dj]. In case of success, the output value is + [fjn ( ... (fj1 default) ...)] where the [fjk] are the values produced by + [djk]. - The [record] combinator is useful to define decoders for records, - in which fields may be given in any order. For every field, each - decoder in the list produces a function that updates the - corresponding field of the record. Each field entry is processed in - the order in which they appear. Each field is optional. + The [record] combinator is useful to define decoders for records, in which + fields may be given in any order. For every field, each decoder in the + list produces a function that updates the corresponding field of the + record. Each field entry is processed in the order in which they appear. + Each field is optional. - Example: + Example: - {[ - # type t = { fst: int; snd: bool };; - type t = { fst : int; snd : bool; } + {[ + # type t = { fst: int; snd: bool };; + type t = { fst : int; snd : bool; } - # let d = - record ~default:{ fst = 0; snd = false } - [ "fst", (let+ i = int in fun t -> { t with fst = i }) - ; "snd", (let+ b = bool in fun t -> { t with snd = b }) - ];; - val d: t decoder = - ]} + # let d = + record ~default:{ fst = 0; snd = false } + [ "fst", (let+ i = int in fun t -> { t with fst = i }) + ; "snd", (let+ b = bool in fun t -> { t with snd = b }) + ];; + val d: t decoder = + ]} - The decoder [d] will produce the following results: + The decoder [d] will produce the following results: - {[ - # run d (List [List [Atom "fst"; Atom "42"]; List [Atom "snd"; Atom "true"]]) - - : t option = Some {fst = 42; snd = true} + {[ + # run d (List [List [Atom "fst"; Atom "42"]; List [Atom "snd"; Atom "true"]]) + - : t option = Some {fst = 42; snd = true} - # run d (List [List [Atom "snd"; Atom "false"]; List [Atom "fst"; Atom "42"]]);; - - : t option = Some {fst = 42; snd = false} + # run d (List [List [Atom "snd"; Atom "false"]; List [Atom "fst"; Atom "42"]]);; + - : t option = Some {fst = 42; snd = false} - # run d (List [List [Atom "snd"; Atom "true"]]);; - - : t option = Some {fst = 0; snd = true} + # run d (List [List [Atom "snd"; Atom "true"]]);; + - : t option = Some {fst = 0; snd = true} - # run d (List [List [Atom "fst"; Atom "42"]]);; - - : t option = Some {fst = 42; snd = false} + # run d (List [List [Atom "fst"; Atom "42"]]);; + - : t option = Some {fst = 42; snd = false} - # run d (List [List [Atom "fst"; Atom "42"]; List [Atom "fst"; Atom "43"]]);; - - : t option = Some {fst = 43; snd = false} - ]} - *) + # run d (List [List [Atom "fst"; Atom "42"]; List [Atom "fst"; Atom "43"]]);; + - : t option = Some {fst = 43; snd = false} + ]} *) val fields : default:'a -> (string * ('a -> 'a) decoder) list -> 'a decoder - (** [fields] has the same behaviour as [record], with the difference - that the enclosing [List [...]] is not expected. In other words, - [record ~default fs = group (fields ~default fs)]. *) + (** [fields] has the same behaviour as [record], with the difference that the + enclosing [List [...]] is not expected. In other words, + [record ~default fs = group (fields ~default fs)]. *) val record_advanced : default:'a -> (string * [< `Required | `Unique ] list * ('a -> 'a) decoder) list -> 'a decoder - (** Same as [record], but with the ability to specify whether fields - are mandatory (i.e., they must appear at least once), or whether - they are unique (i.e., they must appear at most once). Fields with - an empty list of options may appear 0, 1 or more times. *) + (** Same as [record], but with the ability to specify whether fields are + mandatory (i.e., they must appear at least once), or whether they are + unique (i.e., they must appear at most once). Fields with an empty list of + options may appear 0, 1 or more times. *) val fields_advanced : default:'a -> (string * [< `Required | `Unique ] list * ('a -> 'a) decoder) list -> 'a decoder - (** [fields_advanced] has the same behaviour as [record_advanced], - with the difference that the enclosing [List [...]] is not - expected. In other words, - [record_advanced ~default fs = group (fields_advanced ~default fs)]. *) + (** [fields_advanced] has the same behaviour as [record_advanced], with the + difference that the enclosing [List [...]] is not expected. In other + words, + [record_advanced ~default fs = group (fields_advanced ~default fs)]. *) (** {2 Combinators for tuples} *) val pair : 'a decoder -> 'b decoder -> ('a * 'b) decoder - (** [pair d1 d2] decodes a pair: it first decodes using [d1], then - using [d2] if [d1] succeeds. The decoded result is [(v1, v2)], - where [v1] is returned by [d1] and [v2] is return by [d2]. *) + (** [pair d1 d2] decodes a pair: it first decodes using [d1], then using [d2] + if [d1] succeeds. The decoded result is [(v1, v2)], where [v1] is returned + by [d1] and [v2] is return by [d2]. *) val ( <*> ) : 'a decoder -> 'b decoder -> ('a * 'b) decoder (** [d1 <*> d2] is the same as [pair d1 d2] *) @@ -315,17 +310,16 @@ module type S = sig (** {2 Combinators for options and lists} *) val option : 'a decoder -> 'a option decoder - (** Decoder for the standard representation of options as - S-expressions. + (** Decoder for the standard representation of options as S-expressions. - [option d] decodes [List []] into [None], and [List [e]] into [Some v] - where the decoder [d] decodes [e] into [v]. *) + [option d] decodes [List []] into [None], and [List [e]] into [Some v] + where the decoder [d] decodes [e] into [v]. *) val list : 'a decoder -> 'a list decoder (** Decoder for the standard representation of lists as S-expressions. - [list d] decodes [List [e1; ...; en]] into the list [[v1; ...; vn]] - where the decoder [d] decodes every element [ei] into a value [vi]. *) + [list d] decodes [List [e1; ...; en]] into the list [[v1; ...; vn]] where + the decoder [d] decodes every element [ei] into a value [vi]. *) val list1 : 'a decoder -> 'a list decoder (** Same as [list], but for non-empty lists *) @@ -333,23 +327,24 @@ module type S = sig (** {2 Combinators for optional decoding} *) val maybe : 'a decoder -> 'a option decoder - (** [maybe d] produces [Some v] if [d] produces a value [v], and [None] if [d] fails *) + (** [maybe d] produces [Some v] if [d] produces a value [v], and [None] if [d] + fails *) val maybe_with_default : 'a -> 'a decoder -> 'a decoder - (** [maybe_with_default default d] produces [v] if [d] produces a - value [v], and returns the value [default] if [d] fails *) + (** [maybe_with_default default d] produces [v] if [d] produces a value [v], + and returns the value [default] if [d] fails *) (** {2 Combinators for repetitions} *) val repeat_list : until:unit decoder -> 'a decoder -> 'a list decoder - (** [repeat_list ~until d] recognizes [e1; ...; en; f] such that - [until] recognizes [f] and such that [d] recognizes each [ei]. If - [di] produces [vi], then [repeat_list ~until d] produces the list - [v1; ... ; vn]. [d] can succeed 0 or more times. *) + (** [repeat_list ~until d] recognizes [e1; ...; en; f] such that [until] + recognizes [f] and such that [d] recognizes each [ei]. If [di] produces + [vi], then [repeat_list ~until d] produces the list [v1; ... ; vn]. [d] + can succeed 0 or more times. *) val repeat1_list : until:unit decoder -> 'a decoder -> 'a list decoder - (** [repeat1_list ~until d] is similar to [repeat_list ~until d], but - forces that [d] succeeds at least once *) + (** [repeat1_list ~until d] is similar to [repeat_list ~until d], but forces + that [d] succeeds at least once *) val repeat_full_list : 'a decoder -> 'a list decoder (** [repeat_full_list d] is the same as [repeat_list ~until:no_more d] *) @@ -358,51 +353,48 @@ module type S = sig (** [repeat1_full_list d] is the same as [repeat1_list ~until:no_more d] *) val repeat : until:unit decoder -> unit decoder -> unit decoder - (** [repeat ~until d] is similar to [repeat_list ~until d], but - returns [()] instead of a list *) + (** [repeat ~until d] is similar to [repeat_list ~until d], but returns [()] + instead of a list *) val repeat1 : until:unit decoder -> unit decoder -> unit decoder - (** [repeat1 ~until d] is similar to [repeat1_list ~until d], but - returns [()] instead of a list *) + (** [repeat1 ~until d] is similar to [repeat1_list ~until d], but returns [()] + instead of a list *) val repeat_fold_left : until:unit decoder -> init:'a -> ('a -> 'a) decoder -> 'a decoder - (** [repeat_fold_left ~until ~init d] recognizes [e1; ...; en; f] such - that [until] recognizes [f] and such that [d] recognizes each [ei]. - If [di] produces [fi], then [repeat_list ~until d] produces the - result of the expression [fn (... (f1 init) ...)]. [d] can succeed - 0 or more times. *) + (** [repeat_fold_left ~until ~init d] recognizes [e1; ...; en; f] such that + [until] recognizes [f] and such that [d] recognizes each [ei]. If [di] + produces [fi], then [repeat_list ~until d] produces the result of the + expression [fn (... (f1 init) ...)]. [d] can succeed 0 or more times. *) val repeat_fold_right : until:unit decoder -> init:'a -> ('a -> 'a) decoder -> 'a decoder - (** [repeat_fold_right ~until ~init d] recognizes [e1; ...; en; f] - such that [until] recognizes [f] and such that [d] recognizes each - [ei]. If [di] produces [fi], then [repeat_list ~until d] produces - the result of the expression [f1 (... (fn init) ...)]. [d] can - succeed 0 or more times. *) + (** [repeat_fold_right ~until ~init d] recognizes [e1; ...; en; f] such that + [until] recognizes [f] and such that [d] recognizes each [ei]. If [di] + produces [fi], then [repeat_list ~until d] produces the result of the + expression [f1 (... (fn init) ...)]. [d] can succeed 0 or more times. *) (** {2 Higher-order combinators} *) val filter : ('a -> bool) -> 'a decoder -> 'a decoder - (** [filter p d] succeeds and returns [v] when [d] returns [v] and [p - v = true]. Otherwise, [filter p d] fails. *) + (** [filter p d] succeeds and returns [v] when [d] returns [v] and + [p v = true]. Otherwise, [filter p d] fails. *) val fix : ((unit -> 'a decoder) -> 'a decoder) -> 'a decoder (** Fixpoint combinator: [fix f] is the decoder [d] such that - [d = f (fun () -> d)] *) + [d = f (fun () -> d)] *) end module type INTF = sig module type SEXP = SEXP module type S = S - (** Functor that is parameterized over the definition of - S-expressions. This is useful, as several libraries in the OCaml - redefine the same type, which leads to equivalent but incompatible - type definitions. *) + (** Functor that is parameterized over the definition of S-expressions. This + is useful, as several libraries in the OCaml redefine the same type, which + leads to equivalent but incompatible type definitions. *) module Make (X : SEXP) : S with type sexp := X.t include S with type sexp := Csexp.t - (** The code of the library is specialized on the definition of - S-expressions that is provided by the [Csexp] library. *) + (** The code of the library is specialized on the definition of S-expressions + that is provided by the [Csexp] library. *) end