From 34c1b0884701a71fb5080c984342256661a05e0f Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Fri, 7 Sep 2018 13:53:38 -0600 Subject: [PATCH] create gnet-bomAM.scm for lepton-netlist use in partslists target, clean out old partslist modules we don't actually use any more --- pcb-rnd.mk | 2 +- scheme/gnet-bomAM.scm | 161 +++++++++++++++++++++++++++++++ scheme/gnet-partslist-bom.scm | 127 ------------------------ scheme/gnet-partslist-common.scm | 73 -------------- scheme/gnet-partslist-csv.scm | 86 ----------------- 5 files changed, 162 insertions(+), 287 deletions(-) create mode 100644 scheme/gnet-bomAM.scm delete mode 100644 scheme/gnet-partslist-bom.scm delete mode 100644 scheme/gnet-partslist-common.scm delete mode 100644 scheme/gnet-partslist-csv.scm diff --git a/pcb-rnd.mk b/pcb-rnd.mk index f03b890..5a8072a 100644 --- a/pcb-rnd.mk +++ b/pcb-rnd.mk @@ -31,7 +31,7 @@ partslist: $(SCHEMATICS) Makefile $(AM)/preferred-parts $(CONFIG) rm -f $(PROJECT).unsorted partslist.csv: $(SCHEMATICS) Makefile $(AM)/preferred-parts $(CONFIG) - lepton-netlist -L $(SCHEME) -g partslistgag -o $(PROJECT).csvtmp $(SCHEMATICS) + lepton-netlist -L $(SCHEME) -g bomAM -o $(PROJECT).csvtmp $(SCHEMATICS) (head -n1 $(PROJECT).csvtmp; tail -n+2 $(PROJECT).csvtmp | sort -t \, -k 8 | \ awk -f $(AM)/bin/fillpartscsv | sort ) > $@ && rm -f $(PROJECT).csvtmp diff --git a/scheme/gnet-bomAM.scm b/scheme/gnet-bomAM.scm new file mode 100644 index 0000000..2c22d9d --- /dev/null +++ b/scheme/gnet-bomAM.scm @@ -0,0 +1,161 @@ +;;; Altus Metrum CSV part list plug-in for lepton-netlist +;;; Copyright (C) 2018 Bdale Garbee +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +;;; MA 02111-1301 USA. + +;; -------------------------------------------------------------------------- +;; This program generates a bill of materials in Altus Metrum format. +;; +;; You must have a file 'attribs' in the project directory with one attribute +;; per line of all the attributes you want included, no comments allowed. +;; +;; The output consists of comma-separated fields for each of the attributes +;; per part, quantity of that part, and a space-separated list of refdes. +;; +;; This program is inspired by the 'bom2' netlist module initially written +;; by Matt Ettus. +;; -------------------------------------------------------------------------- + +(use-modules (ice-9 rdelim) + (gnetlist backend-getopt) + (gnetlist schematic) + (srfi srfi-26)) + +(define bomAM:open-input-file + (lambda (options) + (let ((filename (backend-option-ref options 'attrib_file "attribs"))) + (if (file-exists? filename) + (open-input-file filename) + (if (backend-option-ref options 'attribs) #f + (begin + (format (current-error-port) +"ERROR: Attribute file '~A' not found. You must do one of the following:\n" +" - Create an 'attribs' file\n" +" - Specify an attribute file using -Oattrib_file=\n" +" - Specify which attributes to include using -Oattribs=attrib1,attrib2,... (no spaces)\n" +filename) + (primitive-exit 1))))))) + +(define bomAM + (lambda (output-filename) + (let* ((options (backend-getopt + (gnetlist:get-backend-arguments) + '((attrib_file (value #t)) (attribs (value #t))))) + (attriblist (bomAM:parseconfig (bomAM:open-input-file options) options))) + (and attriblist + (begin + (bomAM:printlist (append attriblist (list "quantity" "refdes")) #\,) + (newline) + (bomAM:printbom (bomAM:components (schematic-packages toplevel-schematic) + attriblist) + 0)))))) + +(define bomAM:printbom + (lambda (bomlist count) + (if (not (null? bomlist)) + (if (not (null? (caar bomlist))) + (begin + (bomAM:printlist (cdar bomlist) #\,) + (display #\,) + (bomAM:printcount bomlist 0) + (display #\,) + (bomAM:printrefdes bomlist 0) + (newline) + (bomAM:printbom (cdr bomlist) 0) + ))))) + +(define bomAM:printcount + (lambda (bomlist count) + (if (not (null? bomlist)) + (if (not (null? (caar bomlist))) + (begin + (bomAM:printcount (cons (cons (cdaar bomlist)(cdar bomlist))(cdr bomlist)) (+ count 1)) + ) + (display count) + )))) + +(define bomAM:printrefdes + (lambda (bomlist count) + (if (not (null? bomlist)) + (if (not (null? (caar bomlist))) + (begin + (display (caaar bomlist)) + (if (not (null? (cdaar bomlist))) + (write-char #\ )) + (bomAM:printrefdes (cons (cons (cdaar bomlist)(cdar bomlist))(cdr bomlist)) (+ count 1)) +))))) + +(define bomAM:printlist + (lambda (ls delimiter) + (if (null? ls) + #f + (begin + (display (car ls)) + (if (not (null? (cdr ls))) + (write-char delimiter)) + (bomAM:printlist (cdr ls) delimiter))))) + +; Parses attrib file. Returns a list of read attributes. +(define bomAM:parseconfig + (lambda (port options) + (let ((attribs (backend-option-ref options 'attribs))) + (if attribs (string-split attribs #\,) + (and port + (let ((read-from-file (read-delimited " \n\t" port))) + (cond ((eof-object? read-from-file) + '()) + ((= 0 (string-length read-from-file)) + (bomAM:parseconfig port options)) + (else + (cons read-from-file (bomAM:parseconfig port options)))))))))) + +(define bomAM:match-list? + (lambda (l1 l2) + (cond + ((and (null? l1)(null? l2))#t) + ((null? l1) #f) + ((null? l2) #f) + ((not (string=? (car l1)(car l2)))#f) + (#t (bomAM:match-list? (cdr l1)(cdr l2)))))) + +(define bomAM:match? + (lambda (uref attriblist bomlist) + (if (null? bomlist) + (list (cons (list uref) attriblist)) + (if (bomAM:match-list? attriblist (cdar bomlist)) + (cons (cons (merge (list uref) (caar bomlist) string) attriblist)) + diff --git a/scheme/gnet-partslist-bom.scm b/scheme/gnet-partslist-bom.scm deleted file mode 100644 index 39ab5e6..0000000 --- a/scheme/gnet-partslist-bom.scm +++ /dev/null @@ -1,127 +0,0 @@ -; Copyright © 2012 Keith Packard -; gnet-partslist-bom.scm -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation; either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, -; but WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -; GNU General Public License for more details. -; -; You should have received a copy of the GNU General Public License -; along with this program; if not, write to the Free Software -; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -; The /'s may not work on win32 -(load-from-path "gnet-partslist-common.scm") - -(define (caddddddr s) - (car (cdr (cdr (cdr (cdr (cdr (cdr s)))))))) - -(define (cadddddr s) - (car (cdr (cdr (cdr (cdr (cdr s))))))) - -(define (caddddr s) - (car (cdr (cdr (cdr (cdr s)))))) - -(define multiplier 1) - -(define (partslist-bom:write-part s port) - (let ((quantity (caddddddr s)) - (part (cadddddr s)) - (device (cadr s)) - (value (caddr s))) - (display (* multiplier quantity) port) - (display "," port) - (display part port) - (display "," port) - (display device port) - (display " " port) - (display value port) - (display "\n" port))) - -(define (partslist-bom:write-partslist ls port) - (if (null? ls) - '() - (begin (partslist-bom:write-part (car ls) port) - (partslist-bom:write-partslist (cdr ls) port)))) - -(define (count-same-parts ls) - (if (null? ls) - (append ls) - (let* ((parts-table-no-uref (let ((result '())) - (for-each (lambda (l) (set! result (cons (cdr l) result))) (reverse ls)) - (append result))) - (first-ls (car parts-table-no-uref)) - (match-length (length (member first-ls (reverse parts-table-no-uref)))) - (rest-ls (list-tail ls match-length)) - (match-ls (list-tail (reverse ls) (- (length ls) match-length))) - (uref-ls (let ((result '())) - (for-each (lambda (l) (set! result (cons (car l) result))) match-ls) - (append result)))) - (cons (cons uref-ls (append first-ls (list match-length))) (count-same-parts rest-ls))))) - -(define get-vendor - (lambda (package) - (string-trim-both (gnetlist:get-package-attribute package "vendor")))) - -(define get-loadstatus - (lambda (package) - (string-trim-both (gnetlist:get-package-attribute package "loadstatus")))) - -(define get-vendor-part-number - (lambda (package) - (string-trim-both (gnetlist:get-package-attribute package "vendor_part_number")))) - -(define get-footprint - (lambda (package) - (string-trim-both (gnetlist:get-package-attribute package "footprint")))) - -(define (get-parts-table-bom packages vendor) - (if (null? packages) - '() - (let ((package (car packages))) - (if (and (not (string=? (get-loadstatus package) "noload")) (string=? (get-vendor package) vendor)) - (if (string=? (get-device package) "include") - (get-parts-table-bom (cdr packages) vendor) - (cons (list package - (get-device package) - (get-value package) - (get-footprint package) - (get-vendor package) - (get-vendor-part-number package)) ;; sdb change - (get-parts-table-bom (cdr packages) vendor))) - (get-parts-table-bom (cdr packages) vendor))))) - -(define (get-opt-helper option list) - (if (not (null? list)) - (let ((param (car list))) - (if (and param (string-prefix? option (car param))) - (string-drop (car param) (string-length option)) - (get-opt-helper option (cdr list)))) - #f) - ) - -(define (get-opt option default) - (let ((opt (get-opt-helper (string-append option "=") (gnetlist:get-calling-flags)))) - (if opt - opt - default))) - -(define (get-vendor-match) - (get-opt "vendor" "digikey")) - -(define (set-quantity) - (let ((quant (get-opt "quantity" "1"))) - (set! multiplier (string->number quant)))) - -(define (partslist-bom output-filename) - (let ((port (open-output-file output-filename)) - (parts-table (marge-sort-with-multikey (get-parts-table-bom packages (get-vendor-match)) '(1 2 3 0)))) - (set! parts-table (count-same-parts parts-table)) - (set-quantity) - (partslist-bom:write-partslist parts-table port) - (close-output-port port))) diff --git a/scheme/gnet-partslist-common.scm b/scheme/gnet-partslist-common.scm deleted file mode 100644 index d4c235d..0000000 --- a/scheme/gnet-partslist-common.scm +++ /dev/null @@ -1,73 +0,0 @@ -; Copyright (C) 2001-2010 MIYAMOTO Takanori -; gnet-partslist-common.scm -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation; either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, -; but WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -; GNU General Public License for more details. -; -; You should have received a copy of the GNU General Public License -; along with this program; if not, write to the Free Software -; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define (get-parts-table packages) - (if (null? packages) - '() - (let ((package (car packages))) - (if (string=? (get-device package) "include") - (get-parts-table (cdr packages)) - (cons (list package - (get-device package) - (get-value package) - (gnetlist:get-package-attribute package "footprint")) ;; sdb change - (get-parts-table (cdr packages))))))) - -(define (write-one-row ls separator end-char port) - (if (null? ls) - '() - (begin (display (car ls) port) - (for-each (lambda (st) (display separator port)(display st port)) (cdr ls)) - (display end-char port)))) - -(define (get-sortkey-value ls key-column) - (list-ref (car ls) key-column)) - -(define (marge-sort-sub ls1 ls2 key-column) - (if (or (null? ls1) (null? ls2)) - (append ls1 ls2) - (if (string-ci<=? (get-sortkey-value ls1 key-column) (get-sortkey-value ls2 key-column)) - (cons (car ls1) (marge-sort-sub (cdr ls1) ls2 key-column)) - (cons (car ls2) (marge-sort-sub ls1 (cdr ls2) key-column))))) - -(define (marge-sort ls key-column) - (let ((midpoint (inexact->exact (floor (/ (length ls) 2))))) - (if (<= (length ls) 1) - (append ls) - (let ((top-half (reverse (list-tail (reverse ls) midpoint))) - (bottom-half (list-tail ls (- (length ls) midpoint)))) - (set! top-half (marge-sort top-half key-column)) - (set! bottom-half (marge-sort bottom-half key-column)) - (marge-sort-sub top-half bottom-half key-column))))) - -(define (marge-sort-with-multikey ls key-columns) - (if (or (<= (length ls) 1) (null? key-columns)) - (append ls) - (let* ((key-column (car key-columns)) - (sorted-ls (marge-sort ls key-column)) - (key-column-only-ls - ((lambda (ls) (let loop ((l ls)) - (if (null? l) - '() - (cons (get-sortkey-value l key-column) (loop (cdr l)))))) - sorted-ls)) - (first-value (get-sortkey-value sorted-ls key-column)) - (match-length (length (member first-value (reverse key-column-only-ls)))) - (first-ls (list-tail (reverse sorted-ls) (- (length sorted-ls) match-length))) - (rest-ls (list-tail sorted-ls match-length))) - (append (marge-sort-with-multikey first-ls (cdr key-columns)) - (marge-sort-with-multikey rest-ls key-columns))))) diff --git a/scheme/gnet-partslist-csv.scm b/scheme/gnet-partslist-csv.scm deleted file mode 100644 index 53f9849..0000000 --- a/scheme/gnet-partslist-csv.scm +++ /dev/null @@ -1,86 +0,0 @@ -; Copyright (C) 2001-2010 MIYAMOTO Takanori -; gnet-partslist-csv.scm -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation; either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, -; but WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -; GNU General Public License for more details. -; -; You should have received a copy of the GNU General Public License -; along with this program; if not, write to the Free Software -; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -; The /'s may not work on win32 -(load-from-path "gnet-partslist-common.scm") - -(define partslist-csv:write-top-header - (lambda (port) - (display "device,value,footprint,vendor,vendor_part_number,quantity,refdes\n" port))) - -(define (partslist-csv:write-partslist ls port) - (if (null? ls) - '() - (begin (write-one-row (cdar ls) "," "," port) - (write-one-row (caar ls) " " "\n" port) - (partslist-csv:write-partslist (cdr ls) port)))) - -(define (count-same-parts ls) - (if (null? ls) - (append ls) - (let* ((parts-table-no-uref (let ((result '())) - (for-each (lambda (l) (set! result (cons (cdr l) result))) (reverse ls)) - (append result))) - (first-ls (car parts-table-no-uref)) - (match-length (length (member first-ls (reverse parts-table-no-uref)))) - (rest-ls (list-tail ls match-length)) - (match-ls (list-tail (reverse ls) (- (length ls) match-length))) - (uref-ls (let ((result '())) - (for-each (lambda (l) (set! result (cons (car l) result))) match-ls) - (append result)))) - (cons (cons uref-ls (append first-ls (list match-length))) (count-same-parts rest-ls))))) - -(define get-vendor - (lambda (package) - (gnetlist:get-package-attribute package "vendor"))) - -(define get-vendor-part-number - (lambda (package) - (gnetlist:get-package-attribute package "vendor_part_number"))) - -(define get-footprint - (lambda (package) - (gnetlist:get-package-attribute package "footprint"))) - -(define get-loadstatus - (lambda (package) - (gnetlist:get-package-attribute package "loadstatus"))) - -(define (get-parts-table-csv packages) - (if (null? packages) - '() - (let ((package (car packages))) - (if (string=? (get-device package) "include") - (get-parts-table-csv (cdr packages)) - (if (string=? (get-loadstatus package) "smt") - (cons (list package - (get-device package) - (get-value package) - (get-footprint package) - (get-vendor package) - (get-vendor-part-number package)) ;; sdb change - (get-parts-table-csv (cdr packages))) - (get-parts-table-csv (cdr packages))))))) - -(define partslist-csv - (lambda (output-filename) - (let ((port (open-output-file output-filename)) - (parts-table (marge-sort-with-multikey (get-parts-table-csv packages) '(1 2 3 0)))) - (set! parts-table (count-same-parts parts-table)) - (partslist-csv:write-top-header port) - (partslist-csv:write-partslist parts-table port) - (close-output-port port)))) -- 2.30.2