git.gag.com Git - hw/telelco/blob - 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 (string-append gedadata "/scheme/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       (gnetlist:get-package-attribute package "vendor")))
  70
  71 (define get-vendor-part-number
  72    (lambda (package)
  73       (gnetlist:get-package-attribute package "vendor_part_number")))
  74
  75 (define get-footprint
  76    (lambda (package)
  77       (gnetlist:get-package-attribute package "footprint")))
  78
  79 (define (get-parts-table-bom packages vendor)
  80   (if (null? packages)
  81       '()
  82       (let ((package (car packages)))
  83         (if (string=? (get-vendor package) vendor)
  84             (if (string=? (get-device package) "include")
  85                 (get-parts-table-bom (cdr packages) vendor)
  86                 (cons (list package
  87                             (get-device package)
  88                             (get-value package)
  89                             (get-footprint package)
  90                             (get-vendor package)
  91                             (get-vendor-part-number package)) ;; sdb change
  92                       (get-parts-table-bom (cdr packages) vendor)))
  93             (get-parts-table-bom (cdr packages) vendor)))))
  94
  95
  96 (define (get-vendor-match)
  97   (let ((vendor-param (calling-flag? "vendor" (gnetlist:get-calling-flags))))
  98     (if vendor-param
  99         (cdr vendor-param)
 100         "digikey")))
 101
 102 (define (partslist-bom output-filename)
 103   (let ((port (open-output-file output-filename))
 104         (parts-table (marge-sort-with-multikey (get-parts-table-bom packages (get-vendor-match)) '(1 2 3 0))))
 105     (set! parts-table (count-same-parts parts-table))
 106     (partslist-bom:write-partslist parts-table port)
 107     (close-output-port port)))