git.gag.com Git - hw/altusmetrum/blob - scheme/gnet-partslist-bom.scm

   1 ; Copyright © 2012 Keith Packard <keithp@keithp.com>
   2 ; gnet-partslist-bom.scm
   3 ;
   4 ; This program is free software; you can redistribute it and/or modify
   5 ; it under the terms of the GNU General Public License as published by
   6 ; the Free Software Foundation; either version 2 of the License, or
   7 ; (at your option) any later version.
   8 ;
   9 ; This program is distributed in the hope that it will be useful,
  10 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ; GNU General Public License for more details.
  13 ;
  14 ; You should have received a copy of the GNU General Public License
  15 ; along with this program; if not, write to the Free Software
  16 ; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18 ; The /'s may not work on win32
  19 (load-from-path "gnet-partslist-common.scm")
  20
  21 (define (caddddddr s)
  22   (car (cdr (cdr (cdr (cdr (cdr (cdr s))))))))
  23
  24 (define (cadddddr s)
  25   (car (cdr (cdr (cdr (cdr (cdr s)))))))
  26
  27 (define (caddddr s)
  28   (car (cdr (cdr (cdr (cdr s))))))
  29
  30 (define multiplier 1)
  31
  32 (define (partslist-bom:write-part s port)
  33   (let ((quantity (caddddddr s))
  34         (part (cadddddr s))
  35         (device (cadr s))
  36         (value (caddr s)))
  37     (display (* multiplier quantity) port)
  38     (display "," port)
  39     (display part port)
  40     (display "," port)
  41     (display device port)
  42     (display " " port)
  43     (display value port)
  44     (display "\n" port)))
  45
  46 (define (partslist-bom:write-partslist ls port)
  47   (if (null? ls)
  48       '()
  49       (begin (partslist-bom:write-part (car ls) port)
  50              (partslist-bom:write-partslist (cdr ls) port))))
  51
  52 (define (count-same-parts ls)
  53   (if (null? ls)
  54       (append ls)
  55       (let* ((parts-table-no-uref (let ((result '()))
  56                                     (for-each (lambda (l) (set! result (cons (cdr l) result))) (reverse ls))
  57                                     (append result)))
  58              (first-ls (car parts-table-no-uref))
  59              (match-length (length (member first-ls (reverse parts-table-no-uref))))
  60              (rest-ls (list-tail ls match-length))
  61              (match-ls (list-tail (reverse ls) (- (length ls) match-length)))
  62              (uref-ls (let ((result '()))
  63                         (for-each (lambda (l) (set! result (cons (car l) result))) match-ls)
  64                         (append result))))
  65         (cons (cons uref-ls (append first-ls  (list match-length))) (count-same-parts rest-ls)))))
  66
  67 (define get-vendor
  68    (lambda (package)
  69       (string-trim-both (gnetlist:get-package-attribute package "vendor"))))
  70
  71 (define get-loadstatus
  72    (lambda (package)
  73       (string-trim-both (gnetlist:get-package-attribute package "loadstatus"))))
  74
  75 (define get-vendor-part-number
  76    (lambda (package)
  77       (string-trim-both (gnetlist:get-package-attribute package "vendor_part_number"))))
  78
  79 (define get-footprint
  80    (lambda (package)
  81       (string-trim-both (gnetlist:get-package-attribute package "footprint"))))
  82
  83 (define (get-parts-table-bom packages vendor)
  84   (if (null? packages)
  85       '()
  86       (let ((package (car packages)))
  87         (if (and (not (string=? (get-loadstatus package) "noload")) (string=? (get-vendor package) vendor))
  88             (if (string=? (get-device package) "include")
  89                 (get-parts-table-bom (cdr packages) vendor)
  90                 (cons (list package
  91                             (get-device package)
  92                             (get-value package)
  93                             (get-footprint package)
  94                             (get-vendor package)
  95                             (get-vendor-part-number package)) ;; sdb change
  96                       (get-parts-table-bom (cdr packages) vendor)))
  97             (get-parts-table-bom (cdr packages) vendor)))))
  98
  99 (define (get-opt-helper option list)
 100   (if (not (null? list))
 101       (let ((param (car list)))
 102         (if (and param (string-prefix? option (car param)))
 103             (string-drop (car param) (string-length option))
 104             (get-opt-helper option (cdr list))))
 105       #f)
 106   )
 107
 108 (define (get-opt option default)
 109   (let ((opt (get-opt-helper (string-append option "=") (gnetlist:get-calling-flags))))
 110     (if opt
 111         opt
 112         default)))
 113
 114 (define (get-vendor-match)
 115   (get-opt "vendor" "digikey"))
 116
 117 (define (set-quantity)
 118   (let ((quant (get-opt "quantity" "1")))
 119     (set! multiplier (string->number quant))))
 120
 121 (define (partslist-bom output-filename)
 122   (let ((port (open-output-file output-filename))
 123         (parts-table (marge-sort-with-multikey (get-parts-table-bom packages (get-vendor-match)) '(1 2 3 0))))
 124     (set! parts-table (count-same-parts parts-table))
 125     (set-quantity)
 126     (partslist-bom:write-partslist parts-table port)
 127     (close-output-port port)))