xc - interactive command-line calculator

IEC suffixes

First we list with the IEC suffixes:

(define *suffixes-iec-first-char* '(K M G T P E Z Y))

Based on this, we provide a function that receives a given suffix as a symbol (eg. “m”) and returns a list with one entry for each element of *suffixes-iec-first-char* prepending it to the suffix (eg. “Km”, “Mm”, etc.).

The optional parameter base is the multiplier for each entry (eg. to go from “m” to “Km”, from “Km” to “Mm”, etc.). In the usual case this will be the default of 1000.

Every entry of the list has the “(name input output)” format described above.

(define (build-suffixes-list suffix . rest)
  (let-optionals rest ((base 1000))
    (map (lambda (x y)
           (suffix-rate (string->symbol (format #f "~A~A" x suffix))
                        (expt base y)))
         *suffixes-iec-first-char*
         (iota 10 1))))

Now we declare lists with the suffixes themselves and with the binary-versions of the suffixes (where they are powers of 1024):

(define *suffixes-1000* (build-suffixes-list ""))
(define *suffixes-1024* (build-suffixes-list "i" 1024))

Temperature

(define *suffixes-temperature*
  `((tempk ,identity ,identity)
    (tempc ,(cut + <> 273.15) ,(cut - <> 273.15))
    (tempf ,(lambda (x) (* (+ x 459.67) (/ 5 9)))
           ,(lambda (x) (- (* x (/ 9 5)) 459.67)))))

Length

(define *suffixes-1000-length* (build-suffixes-list "m"))

(define *suffixes-length*
  `((m ,identity ,identity)
    ,@*suffixes-1000-length*
    ,(suffix-rate 'inches 0.02540)
    ,(suffix-rate 'feet 0.30480)
    ,(suffix-rate 'yards 0.9144)
    ,(suffix-rate 'miles 1609.344)
    ,(suffix-rate 'lightyears (* 9.461 (expt 10 15)))))

Mass and weight

While the most commonly used unit for mass is the kilogram, we use grams internally so that conversions based on build-suffixes-list will work. This is probably something that should be fixed.

(define *suffixes-1000-mass* (build-suffixes-list "g"))

(define *suffixes-mass-and-weight*
  `((g ,identity ,identity)
    ,@*suffixes-1000-mass*
    ,(suffix-rate 'tonne 1000000)
    ,(suffix-rate 'pound 0453.59237)))

Time

We define a few time units.

We should probably extend the system of suffixes to allow a list of names for a given suffix, so that we can use singular versions of the names.

(define *suffixes-time*
  `((seconds ,identity ,identity)
    ,(suffix-rate 'minutes    (* 60))
    ,(suffix-rate 'hours      (* 60 60))
    ,(suffix-rate 'days       (* 60 60 24))
    ,(suffix-rate 'weeks      (* 60 60 24 7))
    ,(suffix-rate 'months     (* 60 60 24 29.530589))
    ,(suffix-rate 'years      (* 60 60 24 365.25))\
    ,(suffix-rate 'decades    (* 60 60 24 365.25 10))
    ,(suffix-rate 'centuries  (* 60 60 24 365.25 10 10))
    ,(suffix-rate 'milleniums (* 60 60 24 365.25 10 10 10))))

List of all suffixes

Finally we build a list with all the suffixes we support:

(define *suffixes*
  (append
    *suffixes-1024*
    *suffixes-1000*
    *suffixes-temperature*
    *suffixes-length*
    *suffixes-mass-and-weight*
    *suffixes-time*))

Top-level parser

Here we take care of expressions prefixed with a symbol and an equal sign, which assigns the value to the symbol. We also consume empty lines (comments and whitespace have already been consumed by the lexer).

We use parse-input-expr for the actual evaluation of expressions.

(define (parse-input str)
  (parse-all
    str
    (lambda () (error "parser error"))
    (lambda (str fail parsed)
      (parse-token str fail parsed
        ((#\newline)
         stream-null)
        (((all (bind name symbol?)
               (bind-accum (names '()) cons name)
               (bind op (? binary-operator?))
               (bind-accum (modifiers '()) cons op)
               #\=
               )
          (bind value (rule-apply (cut parse-input-expr *binary-operators* <...>)))
          #\newline)
         (stream
           (fold
             (lambda (name modifier value)
               (let ((new-value
                       ((if (stream-null? modifier)
                          identity
                          (cut
                            (cadr (assoc (stream-car modifier)
                                         (concatenate (map cdr *binary-operators*))))
                            (eval (stream-car name))
                            <>))
                        value)))
                 (eval `(set! ,(stream-car name) ',new-value))
                 new-value))
             (stream-car value)
             names
             modifiers)))
        (((all (not #\newline))
          #\newline)
         (warning "Evaluation of expression failed")
         stream-null)))))

List of binary operators

We list the binary operators that we support, with their associativity, sorted by precedence. All of them are mapped to the standard Scheme functions except for +, which we overload to support addition of strings.

(define (xc-+ . args)
  (cond
    ((every number? args) (apply + args))
    ((every string? args) (apply string-append args))))

(define *binary-operators*
  `((right (#\^ ,expt))
    (left (#\* ,*) (#\/ ,/) (#\% ,modulo))
    (left (#\+ ,xc-+) (#\- ,-))))

We also create a function to evaluate if an object is a binary operator:

(define binary-operator?
  (cute member <>
        (concatenate
          (map (compose (cut map car <>) cdr) *binary-operators*))))

Evaluation of binary operators

parse-input-binary receives a list of binary operators ordered by precedence (in the format of *binary-operators*: grouped by precedence and declaring their associativity) and evaluates all of them, returning the resulting expression.

(define (parse-input-expr ops str fail parsed)
  (parse-token str fail parsed
    (((bind expr
            (rule-apply parse-input-atom)
            (all (bind op-inner binary-operator?)
                 (assert (assoc (stream-car op-inner) (cdar ops)))
                 (rule-apply parse-input-atom)))
      (bind rest
            (? (bind op-rest binary-operator?)
               (assert (not (assoc (stream-car op-rest) (cdar ops))))
               (rule-apply (cut parse-input-expr (list (car ops)) <...>)))))
     (let ((value
             (let loop ((expr expr))
               (cond
                 ((stream-null? (stream-cdr expr))
                  (stream-car expr))
                 ((eq? (caar ops) 'right)
                  ((cadr (assoc (stream-cadr expr) (cdar ops)))
                   (stream-car expr)
                   (loop (stream-cddr expr))))
                 ((eq? (caar ops) 'left)
                  (loop
                    (stream-cons
                      ((cadr (assoc (stream-cadr expr) (cdar ops)))
                       (stream-car expr)
                       (stream-caddr expr))
                      (stream-cdddr expr))))))))
       (if (null? (cdr ops))
         (stream-cons value rest)
         (receive (result stream fail parsed)
                  (parse-input-expr
                    (cdr ops)
                    (stream-cons value rest)
                    fail
                    parsed)
           result))))))

Now a function to simplify testing:

(define (parse-input-expr-test str)
  (stream->list
    (parse-all
      (list->stream str)
      (lambda () (error "test parse-input-expr error"))
      (cut parse-input-expr *binary-operators* <...>))))

Examples:

(parse-input-expr-test '(1 #\- 1 #\+ 1))
=> '(1)
(parse-input-expr-test '(4 #\^ 3 #\^ 2))
=> '(262144)
(parse-input-expr-test '(2 #\* #\( 1 #\+ 1 #\) #\+ 1))
=> '(5)
(parse-input-expr-test '(1 #\+ 2 #\* 3))
=> '(7)
(parse-input-expr-test '(3 #\* 2 #\+ 1 #\^ 4))
=> '(7)
(parse-input-expr-test '("foo" #\+ "bar"))
=> '("foobar")

Atoms

Now the definition of an atom.

We have rules for these cases:

• A parenthized expression.
• A negative number.
• Procedure application, of the form “proc(arg0, ..., argn)”.
• A symbol lookup.

(define (parse-input-atom str fail parsed)
  (parse-token str fail parsed
    ((#\(
      (bind sub (rule-apply (cut parse-input-expr *binary-operators* <...>)))
      #\))
     sub)
    ((#\-
      (bind obj number?))
     (stream (- (stream-car obj))))
    (((bind func symbol?)
      #\(
      (? (bind first-arg (rule-apply (cut parse-input-expr *binary-operators* <...>)))
         (* #\,
            (bind arg (rule-apply (cut parse-input-expr *binary-operators* <...>)))
            (bind-accum (args '()) cons arg)))
      #\))
     (stream
       (condition-case
         (apply
           (eval (stream-car func))
           (if (stream-null? first-arg)
             '()
             (map stream-car (cons first-arg (reverse args)))))
         ((exn)
          (warning "Exception during invocation of procedure" (stream-car func))
          (fail)))))

    (((bind sym symbol?))
     (stream
       (condition-case
         (eval (stream-car sym))
         ((exn)
          (warning "Unable to evaluate symbol" (stream-car sym))
          (fail)))))

    (((bind obj (or number? port? procedure? string?
                    stream? boolean? pair? null?)))
     obj)))

Now a function to simplify testing:

(define (parse-input-atom-test str)
  (stream->list
    (parse-all
      (list->stream str)
      (lambda () (error "test parse-input-atom error"))
      parse-input-atom)))

Examples:

(parse-input-atom-test '(1892))
=> '(1892)
(parse-input-atom-test '(#\( 1 #\+ 1 #\)))
=> '(2)
(parse-input-atom-test '(xc-+ #\( 1 #\, 1 #\)))
=> '(2)
(parse-input-atom-test `(,xc-+))
=> `(,xc-+)
(parse-input-atom-test '(xc-+))
=> `(,xc-+)

Numbers with suffixes

First we define a procedure that, given a particular entry from the *suffixes* list, will output the results using it:

(define output-digits 2)

(define (output-with-suffix suffix num)
  (format #t "~,VF~A~%"
          output-digits
          ((caddr suffix) num)
          (car suffix)))

We also define a “smarter” procedure that will find the suitable suffix from a list, depending the size of the input.

(define (output-with-auto-suffixes limit suffixes)
  (lambda (num)
    (let loop ((suffixes suffixes) (num num))
      (cond
        ((or (< num limit)
             (null? (cdr suffixes)))
         (format #t "~,VF~A~%"
                 output-digits
                 num
                 (caar suffixes)))
        (else
          (loop (cdr suffixes) (/ num limit)))))))

Based on that, we build a list of “systems” of suffixes that we support. The entries in the list are of the form “(name proc)”, where “name” is a symbol naming the system. We take care to make the set of names disjunct from the set of prefixes, so that a given name can uniquely specify either a system of suffixes or a particular suffix.

(define output-base-1024 (output-with-auto-suffixes 1024 (cons (list "") *suffixes-1024*)))
(define output-base-1000 (output-with-auto-suffixes 1000 (cons (list "") *suffixes-1000*)))
(define output-length (output-with-auto-suffixes 1000 (cons (list "m") *suffixes-1000-length*)))
(define output-mass   (output-with-auto-suffixes 1000 (cons (list "g") *suffixes-1000-mass*)))

(define *output-suffixes*
  `((|10| ,output-base-1000)
    (|1000| ,output-base-1000)
    (|2| ,output-base-1024)
    (|1024| ,output-base-1024)
    (length ,output-length)
    (mass ,output-mass)))

Examples:

(with-output-to-string (cut output-base-1024 1023))
=> "1023.00\n"
(with-output-to-string (cut output-base-1024 (* 2 (expt 1024 3))))
=> "2.00Gi\n"
(with-output-to-string (cut output-base-1000 (* 2 (expt 1000 3))))
=> "2.00G\n"
(with-output-to-string (cut output-length (* 2 (expt 1000 2))))
=> "2.00Km\n"

We also define a function to switch from one system or fixed suffix to another. We expect this function to be used interactively, so we make it return the name of the suffix or system selected as a string.

(define (output-suffix arg)
  (let ((data (assoc (string->symbol arg) *output-suffixes*)))
    (if data
      (set! output-num (cadr data))
      (let ((suffix (assoc (string->symbol arg) *suffixes*)))
        (unless suffix
          (error "Invalid type"
                 arg
                 "Expected one of:"
                 (map (compose symbol->string car)
                      (append *output-suffixes* *suffixes*))))
        (set! output-num (cut output-with-suffix suffix <>)))))
  arg)

Literal output

We also support printing the full number:

(define output-int-format-spec "~,VD~%")

(define (output-int num)
  (format #t output-int-format-spec output-digits num))

(define (output-float num)
  (format #t "~,VF~%" output-digits num))

Time intervals

We represent time intervals as numbers of seconds. We support two formats for printing them in a human-readable way: “5d03h20m12s” and “5:03:20:12”. We also allow the user to specify whether to also use weeks (when the number of days is greater than 6).

(define *show-start* 'd)
(define *show-colons* #t)

(define (output-time num)
  (cond
    ((negative? num)
     (format #t "-")
     (output-time (- num)))
    (else
      (let loop ((num num)
                 (data (find-tail (lambda (x) (eq? *show-start* (cadr x)))
                                  '((604800 w 0) (86400 d 1) (3600 h 2) (60 m 2))))
                 (force-print #f))
        (cond
          ((null? data)
           (format #t "~V,'0D~A~%"
                   (if force-print 2 0)
                   (inexact->exact (round num))
                   (if *show-colons* "" "s")))
          ((or (>= num (caar data))
               force-print)
           (format #t "~V,'0D~A"
                   (if force-print (caddar data) 0)
                   (inexact->exact (quotient num (caar data)))
                   (if *show-colons* ":" (cadar data)))
           (loop (remainder num (caar data)) (cdr data) #t))
          (else
            (loop num (cdr data) #f)))))))

Default output format

The function output-num will be used to print numbers. We set it to output-base-1024 by default:

(define output-num output-base-1024)

Command line arguments

We support a few command-line arguments to specify the prefered output format.

First we create a list of supported args. The args:make-option and related functionality is provided by the args egg.

(define supported-args
  (list
    (args:make-option
      (f float)
      #:none
      "Output numbers as floats"
      (set! output-num output-float))
    (args:make-option
      (h help)
      #:none
      "Display this text"
      (usage))
    (args:make-option
      (b base)
      (#:required "BASE")
      "Set the desired base for the output"
      (set! output-num output-int)
      (cond
        ((string=? arg "16")
         (set! output-int-format-spec "~,VX~%"))
        ((string=? arg "10")
         (set! output-int-format-spec "~,VD~%"))
        ((string=? arg "8")
         (set! output-int-format-spec "~,VO~%"))
        ((string=? arg "2")
         (set! output-int-format-spec "~,VB~%"))
        (else
         (error "Invalid base (expected 2, 8, 10 or 16)" arg))))
    (args:make-option
      (s suffix)
      (#:required "TYPE")
      "Set the system of suffixes used for the output (try 'help')"
      (output-suffix arg))
    (args:make-option
      (t time)
      #:none
      "Output numbers as time intervals (specified as numbers of seconds)"
      (set! output-num output-time))
    (args:make-option
      (tn time-names)
      #:none
      "Output time with names of units instead of colons"
      (set! *show-colons* #f))
    (args:make-option
      (tw time-weeks)
      #:none
      "Output time with number of weeks"
      (set! *show-start* 'w))))

The usage function will show a header and footer around the list of supported arguments:

(define (usage)
  (format #t "Usage: ~A [OPTION ...] [FILE ...]~%~%" (car (argv)))
  (format #t (args:usage supported-args))
  (format #t "~%Report bugs to azul@freaks-unidos.net.~%")
  (format #t "Check http://wiki.freaks-unidos.net/xc for newer versions.~%")
  (exit 1))

And finally we parse all arguments. We treat operands as files, which we load:

(define (parse-args args)
  (receive (options operands)
    (args:parse args supported-args)
    (for-each load operands)))

RC File

We automatically load a “~/.xcrc” file, where the user can define, in Scheme code, functions that he wants to call from xc:

(define (load-main-rc)
  (let ((rc (make-pathname (getenv "HOME") ".xcrc")))
    (when (file-exists? rc)
      (load rc))))

Main function

(run-tests)
(parse-args (command-line-arguments))
(load-main-rc)
(stream-for-each
  (lambda (obj)
    (if (number? obj)
      (output-num obj)
      (format #t "~S~%" obj)))
  (parse-input (lexer (port->stream))))