scheme/gbx2ps.scm

   1 #!/bin/sh
   2 exec guile -l parse-gerber.scm -e main -s "$0" "$@"
   3 !#
   4
   5 ; gEDA - GNU Electronic Design Automation
   6 ; parse-gerber.scm
   7 ; Copyright (C) 2000-2001 Stefan Petersen (spe@stacken.kth.se)
   8 ;
   9 ; $Id$
  10 ;
  11 ; This program is free software; you can redistribute it and/or modify
  12 ; it under the terms of the GNU General Public License as published by
  13 ; the Free Software Foundation; either version 2 of the License, or
  14 ; (at your option) any later version.
  15 ;
  16 ; This program is distributed in the hope that it will be useful,
  17 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ; GNU General Public License for more details.
  20 ;
  21 ; You should have received a copy of the GNU General Public License
  22 ; along with this program; if not, write to the Free Software
  23 ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
  24
  25
  26 (define *last-aperture-type* '())
  27 (define *last-x* '())
  28 (define *last-y* '())
  29
  30 (define (ps-preamble port)
  31   (display "%!\n" port)
  32   (display "%generated by gerbv\n\n" port)
  33   (display "/inch {72 mul} def\n" port)
  34   (display "/mm {2.54 div} def\n" port)
  35   (newline port)
  36   (display "1.5 inch 3 inch translate\n" port)
  37   (newline port)
  38   (if (equal? (assoc-ref *image* 'polarity) 'positive)
  39       (begin
  40         (display "/Black {0 setgray} def\n" port)
  41         (display "/White {1 setgray} def\n" port))
  42       (begin
  43         (display "/Black {1 setgray} def % Polarity reversed\n" port)
  44         (display "/White {0 setgray} def\n" port)))
  45   (newline port)
  46   (display "/circle { % x y id od\n" port)
  47   (display "    gsave\n" port)
  48   (display "    3 index 3 index moveto\n" port)
  49   (display "    3 index 3 index 3 2 roll % Fix arguments\n" port)
  50   (display "    2 div % d given, need r\n" port)
  51   (display "    0 360 arc Black fill % outer\n" port)
  52   (display "    2 div % d given, need r\n" port)
  53   (display "    0 360 arc White fill %inner\n" port)
  54   (display "grestore\n" port)
  55   (display "} def\n" port)
  56   (newline port)
  57   (display "/rectangle { % x y xl yl\n" port)
  58   (display "    gsave\n" port)
  59   (display "    newpath\n" port)
  60   (display "    1 setlinewidth\n" port)
  61   (display "    3 index 2 index 2 div sub\n" port)
  62   (display "    3 index 2 index 2 div add moveto\n" port)
  63   (display "    1 index 0 rlineto\n" port) ; ->
  64   (display "    dup -1 mul 0 exch rlineto\n" port) ; \!/
  65   (display "    1 index -1 mul 0 rlineto\n" port) ; <-
  66   (display "    dup 0 exch rlineto\n" port) ; /!\
  67   (display "    pop pop pop pop closepath  Black fill\n" port)
  68   (display "    grestore\n" port)
  69   (display "} def\n" port)
  70   (newline port)
  71   (set! *max-x* (+ *max-x* 100))
  72   (set! *max-y* (+ *max-y* 100))
  73   (set! *min-x* (- *min-x* 100))
  74   (set! *min-y* (- *min-y* 100))
  75   (display "gsave 72 setlinewidth newpath\n" port)
  76   (display (string-append (number->string *max-x*) " 1000 div inch ") port)
  77   (display (string-append (number->string *max-y*) " 1000 div inch moveto\n") port)
  78   (display (string-append (number->string *max-x*) " 1000 div inch ") port)
  79   (display (string-append (number->string *min-y*) " 1000 div inch lineto\n") port)
  80   (display (string-append (number->string *min-x*) " 1000 div inch ") port)
  81   (display (string-append (number->string *min-y*) " 1000 div inch lineto\n") port)
  82   (display (string-append (number->string *min-x*) " 1000 div inch ") port)
  83   (display (string-append (number->string *max-y*) " 1000 div inch lineto\n") port)
  84   (display "closepath White fill grestore\n" port)
  85   (newline port))
  86
  87 (define (print-ps-element element port)
  88   (let ((x (car element))
  89         (y (cadr element))
  90         (aperture-type (car (caddr element)))
  91         (aperture-state (cdr (caddr element))))
  92     (cond ((eq? aperture-state 'exposure-off)
  93            (handle-line-aperture aperture-type port)
  94            (print-position x y port)
  95            (display "moveto\n" port))
  96           ((eq? aperture-state 'exposure-on)
  97            (handle-line-aperture aperture-type port)
  98            (print-position x y port)
  99            (display "lineto\n" port))
 100           ((eq? aperture-state 'exposure-flash)
 101            (print-position x y port)
 102            (print-flash-aperture aperture-type port)))
 103     (set! *last-x* x)
 104     (set! *last-y* y)))
 105
 106 (define (print-position x y port)
 107   (display x port) ; X axis
 108   (display " 1000 div " port)
 109   (display (assoc-ref *image* 'unit) port)
 110   (display " " port)
 111   (display y port) ; Y axis
 112   (display " 1000 div " port)
 113   (display (assoc-ref *image* 'unit) port)
 114   (display " " port))
 115
 116 (define (handle-line-aperture aperture-type port)
 117   (cond ((null? *last-aperture-type*) ; First time
 118          (set! *last-aperture-type* aperture-type)
 119          (display (get-aperture-size aperture-type) port)
 120          (display " inch setlinewidth\n" port))
 121         ((not (eq? *last-aperture-type* aperture-type)) ; new aperture
 122          (display "stroke\n" port)
 123          (display *last-x* port) ; X Axis
 124          (display " 1000 div " port)
 125          (display (assoc-ref *image* 'unit) port)
 126          (display " " port)
 127          (display *last-y* port)
 128          (display " 1000 div " port)
 129          (display (assoc-ref *image* 'unit) port)
 130          (display " moveto\n" port)
 131          (display (get-aperture-size aperture-type) port)
 132          (display " inch setlinewidth\n" port)
 133          (set! *last-aperture-type* aperture-type))))
 134
 135 (define (print-flash-aperture aperture-type port)
 136   (let* ((aperture-description (assv aperture-type *aperture-description*))
 137          (symbol (cadr aperture-description))
 138          (sizes (cddr aperture-description)))
 139     (case (length sizes)
 140       ((1)
 141        (display " 0 " port)
 142        (display (car sizes) port)
 143        (display " inch " port))
 144       ((2)
 145        (display (car sizes) port)
 146        (display " inch " port)
 147        (display (cadr sizes) port)
 148        (display " inch " port)))
 149     (case symbol
 150       ((circle)
 151        (display " circle" port))
 152       ((rectangle)
 153 ;       (display " pop pop moveto " port))
 154        (display " rectangle  " port))
 155       (else
 156        (display " moveto %unknown" port))))
 157   (newline port))
 158
 159 (define (get-aperture-size type)
 160   (let ((desc (assv type *aperture-description*)))
 161     (if desc
 162         (caddr desc))))
 163
 164
 165 (define (generate-ps netlist port)
 166   (ps-preamble port)
 167   (for-each (lambda (element)
 168               (print-ps-element element port))
 169             netlist)
 170   (display "stroke\nshowpage\n" port))
 171
 172 (define *max-x* 0)
 173 (define *max-y* 0)
 174 (define *min-x* 30000)
 175 (define *min-y* 30000)
 176
 177 (define (find-boundaries netlist)
 178   (if (null? netlist)
 179       '()
 180       (let ((x (string->number (caar netlist)))
 181             (y (string->number (cadar netlist))))
 182         (if (< x *min-x*)
 183             (set! *min-x* x))
 184         (if (< y *min-y*)
 185             (set! *min-y* y))
 186         (if (> x *max-x*)
 187             (set! *max-x* x))
 188         (if (> y *max-y*)
 189             (set! *max-y* y))
 190         (find-boundaries (cdr netlist)))))
 191
 192 (define (main args)
 193   (let ((infile 'stdin)    ; this doesn't work
 194         (outfile "foo.ps")) ; this doesn't work
 195     (case (length args)
 196       ((2)
 197        (set! infile (cadr args)))
 198       ((3)
 199        (set! infile (cadr args))
 200        (set! outfile (caddr args)))
 201     (else
 202      (display "Wrong number of arguments.\n    ")
 203      (display (car args))
 204      (display " infile [outfile]")
 205      (newline)
 206      (exit)))
 207     (call-with-input-file infile parse-gerber)
 208     (find-boundaries (reverse *netlist*))
 209     (call-with-output-file outfile
 210       (lambda (port)
 211         (generate-ps (reverse *netlist*) port)))))