Invoice

February 17, 2015

; invoice

(define-syntax list-match
  (syntax-rules ()
    ((_ expr (pattern fender ... template) ...)
      (let ((obj expr))
        (cond ((list-match-aux obj pattern fender ...
                (list template)) => car) ...
              (else (error 'list-match "pattern failure")))))))

(define-syntax list-match-aux
  (lambda (stx)
    (define (underscore? x)
      (and (identifier? x) (free-identifier=? x (syntax _))))
    (syntax-case stx (quote quasiquote)
      ((_ obj pattern template)
        (syntax (list-match-aux obj pattern #t template)))
      ((_ obj () fender template)
        (syntax (and (null? obj) fender template)))
      ((_ obj underscore fender template)
        (underscore? (syntax underscore))
        (syntax (and fender template)))
      ((_ obj var fender template)
        (identifier? (syntax var))
        (syntax (let ((var obj)) (and fender template))))
      ((_ obj (quote datum) fender template)
        (syntax (and (equal? obj (quote datum)) fender template)))
      ((_ obj (quasiquote datum) fender template)
        (syntax (and (equal? obj (quasiquote datum)) fender template)))
      ((_ obj (kar . kdr) fender template)
        (syntax (and (pair? obj)
                (let ((kar-obj (car obj)) (kdr-obj (cdr obj)))
                  (list-match-aux kar-obj kar
                        (list-match-aux kdr-obj kdr fender template))))))
      ((_ obj const fender template)
        (syntax (and (equal? obj const) fender template))))))

(define (julian year month day)
  (let* ((a (quotient (- 14 month) 12))
         (y (+ year 4800 (- a)))
         (m (+ month (* 12 a) -3)))
    (+ day
       (quotient (+ (* 153 m) 2) 5)
       (* 365 y)
       (quotient y 4)
       (- (quotient y 100))
       (quotient y 400)
       (- 32045))))

(define (today) ; Chez Scheme
  (julian
    (date-year (current-date))
    (date-month (current-date))
    (date-day (current-date))))

(define (date-format julian fmt-string)
  (define (pad n)
    (if (string n)
      (string-append "0" (number->string n))))
  (let ((ds (vector "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
        (days (vector "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
        (ms (vector "" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
        (months (vector "" "January" "February" "March" "April" "May" "June" "July" "August"
          "September" "October" "November" "December")))
    (let-values (((year month day) (gregorian julian)) ((weekday) (modulo julian 7)))
      (let loop ((fmt (string->list fmt-string)) (cs (string)))
        (list-match fmt
          (() cs)
          ((#\% #\% . rest) (loop (cddr fmt) (string-append cs "%")))
          ((#\% #\a . rest) (loop (cddr fmt) (string-append cs (vector-ref ds weekday))))
          ((#\% #\A . rest) (loop (cddr fmt) (string-append cs (vector-ref days weekday))))
          ((#\% #\b . rest) (loop (cddr fmt) (string-append cs (vector-ref ms month))))
          ((#\% #\B . rest) (loop (cddr fmt) (string-append cs (vector-ref months month))))
          ((#\% #\d . rest) (loop (cddr fmt) (string-append cs (pad day))))
          ((#\% #\D . rest) (loop (cddr fmt) (string-append cs (number->string day))))
          ((#\% #\m . rest) (loop (cddr fmt) (string-append cs (pad month))))
          ((#\% #\M . rest) (loop (cddr fmt) (string-append cs (number->string month))))
          ((#\% #\y . rest) (loop (cddr fmt) (string-append cs (substring (number->string year) 2 4))))
          ((#\% #\Y . rest) (loop (cddr fmt) (string-append cs (number->string year))))
          ((c . rest) (loop (cdr fmt) (string-append cs (string c)))))))))

(define (write-invoice)
  (let-values (((ds qs ps tot) (read-items)))
    (when (pair? ds)
      (format #t "~10a~20a~%" "" "Praxis Grocery Store")
      (format #t "~15a~11a~%~%" "" (date-format (today) "%d %b %Y"))
      (do ((i 1 (+ i 1)) (ds ds (cdr ds)) (qs qs (cdr qs)) (ps ps (cdr ps)))
        ((null? ds))
        (format #t "~3a~20a~3@a~6,2f~8,2f~%" i (car ds) (car qs) (car ps) (* (car qs) (car ps))))
      (format #t "~32a~8,2f~%" "   Subtotal" tot)
      (format #t "~32a~8,2f~%" "   Tax 5.25%" (* tot 0.0525))
      (format #t "~32a~8,2f~%" "   Total" (* tot 1.0525)))))

(define (read-items)
  (let loop ((ds (list)) (qs (list)) (ps (list)) (tot 0))
    (display "Description? ")
    (let ((descrip (get-line (current-input-port))))
      (if (zero? (string-length descrip))
          (values (reverse ds) (reverse qs) (reverse ps) tot)
          (begin (display "Quantity? ")
                 (let ((quant (string->number (get-line (current-input-port)))))
                   (display "Unit price? ")
                   (let ((price (string->number (get-line (current-input-port)))))
                     (loop (cons descrip ds) (cons quant qs) (cons price ps)
                           (+ tot (* quant price))))))))))

Pages: 1 2 3

One Response to “Invoice”

  1. use strict;
    use Date::Format qw(time2str);
    my $c = 0;
    my $t = 0;
    my @Q;
    while(1) {
      print STDERR "Product > "; my $p = <STDIN>; chomp $p;
      last unless $p =~ /\S/;
      print STDERR "Quantity> "; my $q = <STDIN>; chomp $q;
      print STDERR "Price   > "; my $a = <STDIN>; chomp $a;
      $c++;
      $t+=$q*$a;
      push @Q, [$c,$p,$q,$a,$q*$a];
    }
    printf '
               Praxis Grocery Store
                   %s
    %s
       Subtotal                          %7.2f
       Tax 5.25%%                         %7.2f
       Total                             %7.2f
    ',
     time2str( "%e %b %Y", time ),
     (join q(), map { sprintf "\n%2d %-20s %2d  %7.2f  %7.2f", @{$_} } @Q ),
     $t, $t*0.0525, $t*1.0525;
    

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: