xc - interactive command-line calculator

abs in 64 bits

We've encountered Chicken versions (in particular, 3.4.0 in a 64-bit build) where applying the default abs to a large number incorrectly returns a negative number. We add a small workaround for this:

(when (negative? (abs 2147483648))
  (set! abs
    (lambda (x)
      (if (negative? x) 
        (- x)
        x))))

Examples:

(abs 2147483648)
=> 2147483648

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)
    ,(suffix-add 'tempc 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*))

Error control

Sometimes, specially when running in interactive mode, errors in the evaluation of expressions should not stop the execution of the program, but they should simply display a warning to the user. This is the default mode. However, in non-interactive use of xc (eg. calling it from a script to perform some computations), aborting the execution and returning an exit code is often a preferable behavior.

We provide a handle-user-error procedure to be called during the evaluation of expressions when an error takes. It is defined to either warning or error. It can be set with a command-line argument (see below).

(define handle-user-error warning)

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.

If *show-scheme-expressions* is set to true, we show the Scheme expressions to which the user expressions get compiled.

(define *show-scheme-expressions* #f)

(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)
               (or ((bind op (? binary-operator?)))
                   ((bind func #\()
                    (all
                      (bind arg symbol?)
                      (? #\,)
                      (bind-accum (args '()) cons arg))
                    #\)))
               (bind-accum (modifiers '()) cons (list op func args))
               #\=
               )
          (bind expr (rule-apply (cut parse-input-expr *binary-operators* <...>)))
          #\newline)
         (when *show-scheme-expressions*
           (format #t "[~A]~%" (stream-car expr)))
         (condition-case
           (stream
             (eval
               (fold
                 (lambda (name modifier expr)
                   (let ((expr-adjusted
                           (cond
                             ((not (stream-null? (car modifier)))
                              `(,(cadr (assoc (stream-car (car modifier))
                                              (concatenate (map cdr *binary-operators*))))
                                 ,(stream-car name)
                                 ,expr))
                             ((not (stream-null? (cadr modifier)))
                              `(lambda ,(map stream-car (reverse (caddr modifier))) ,expr))
                             (else
                               expr))))
                     (eval `(set! ,(stream-car name) ,expr-adjusted))
                     (stream-car name)))
                 (stream-car expr)
                 names
                 modifiers)))
           ((exn)
            (handle-user-error "Failed to evaluate expression")
            stream-null)))
        (((all (not #\newline))
          #\newline)
         (handle-user-error "Failed to compile expression")
         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-with-suffix)
            (all (bind op-inner binary-operator?)
                 (assert (assoc (stream-car op-inner) (cdar ops)))
                 (rule-apply parse-input-atom-with-suffix)))
      (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))
=> '((xc-+ (- 1 1) 1))
(parse-input-expr-test '(4 #\^ 3 #\^ 2))
=> '((expt 4 (expt 3 2)))
(parse-input-expr-test '(2 #\* #\( 1 #\+ 1 #\) #\+ 1))
=> '((xc-+ (* 2 (xc-+ 1 1)) 1))
(parse-input-expr-test '(1 #\+ 2 #\* 3))
=> '((xc-+ 1 (* 2 3)))
(parse-input-expr-test '(3 #\* 2 #\+ 1 #\^ 4))
=> '((xc-+ (* 3 2) (expt 1 4)))
(parse-input-expr-test '("foo" #\+ "bar"))
=> '((xc-+ "foo" "bar"))

Atoms

Now the definition of an atom.

We have rules for these cases:

• A parenthized expression.
• An athom preceeded by a “-”.
• Procedure application, of the form “proc(arg0, ..., argn)”.
• A literal object (eg. a number, string or symbol).

(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 (rule-apply parse-input-atom)))
     (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
       `(,(stream-car func)
         ,@(if (stream-null? first-arg)
             '()
             (map stream-car (cons first-arg (reverse args)))))))
    (((bind obj (or number? port? procedure? string? symbol?
                    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 #\)))
=> '((xc-+ 1 1))
(parse-input-atom-test '(foo #\( 1 #\, 1 #\)))
=> '((foo 1 1))
(parse-input-atom-test '(foo))
=> `(foo)

Suffixes in expressions

We provide a simple wrapper around parse-input-atom that takes care of conversion based on suffixes:

(define (parse-input-atom-with-suffix str fail parsed)
  (parse-token str fail parsed
    (((bind atom (rule-apply parse-input-atom))
      (? (bind suffix symbol?)
         (assert (assoc (stream-car suffix) *suffixes*))))
     (stream
       ((if (stream-null? suffix)
          identity
          (lambda (expr)
            `(',(cadr (assoc (stream-car suffix) *suffixes*)) ,expr)))
        (stream-car atom))))))

Now a function to simplify testing:

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

Examples:

(parse-input-atom-with-suffix-test '(1234))
=> 1234
(parse-input-atom-with-suffix-test '(1 K))
=> 1000
(parse-input-atom-with-suffix-test '(#\( 1 #\+ 1 K #\)))
=> 1001
(parse-input-atom-with-suffix-test '(#\( 1 #\+ 1 #\) K))
=> 2000

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)
    (when (negative? num)
      (format #t "-"))
    (let loop ((suffixes suffixes) (num (abs num)))
      (if (or (< num limit)
              (null? (cdr suffixes)))
        (format #t "~,VF~A~%" output-digits num (caar suffixes))
        (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.00Mm\n"
(with-output-to-string (cut output-base-1000 (* -2 (expt 1000 3))))
=> "-2.00G\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 *suffixes-names*
  (map car (append *suffixes* *output-suffixes*)))

(define (output-suffix arg . rest)
  (let-optionals rest ((exit-on-help #f))
    (cond
      ((equal? arg "help")
       (format #t "Supported suffixes:~{ ~A~}~%" *suffixes-names*)
       (when exit-on-help
         (exit 0)))
      ((assoc (string->symbol arg) *output-suffixes*) =>
       (lambda (value)
         (set! output-num (cadr value))))
      ((assoc (string->symbol arg) *suffixes*) =>
       (lambda (value)
         (set! output-num (cut output-with-suffix value <>))))
      (else
        (error "Invalid type"
               arg
               "Expected one of:"
               *suffixes-names*))))
  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 . rest)
  (let-optionals rest ((show-start *show-start*) (show-colons *show-colons*))
    (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 (floor (/ num (caar data))))
                     (if show-colons ":" (cadar data)))
             (loop (modulo num (caar data)) (cdr data) #t))
            (else
              (loop num (cdr data) #f))))))))

Examples:

(with-output-to-string (cut output-time 86400))
=> "1:00:00:00\n"
(with-output-to-string (cut output-time -86400))
=> "-1:00:00:00\n"
(with-output-to-string (cut output-time 86400.4))
=> "1:00:00:00\n"
(with-output-to-string (cut output-time 86400.6))
=> "1:00:00:01\n"
(with-output-to-string (cut output-time 86399))
=> "23:59:59\n"
(with-output-to-string (cut output-time 59))
=> "59\n"
(with-output-to-string (cut output-time (* 14 86400)))
=> "14:00:00:00\n"
(with-output-to-string (cut output-time (* 14 86400) 'w))
=> "2:0:00:00:00\n"
(with-output-to-string (cut output-time (* 6 86400) 'w))
=> "6:00:00:00\n"
(with-output-to-string (cut output-time (* 7 86400) 'w #f))
=> "1w0d00h00m00s\n"

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 (without units)"
      (set! output-num output-float))
    (args:make-option
      (d digits)
      (#:required "DIGITS")
      "Number of decimal digits shown"
      (let ((num-arg (string->number arg)))
        (unless num-arg
          (error "Invalid value (expected number)" num-arg))
        (set! output-digits num-arg)))
    (args:make-option
      (h help)
      #:none
      "Display this text"
      (usage))
    (args:make-option
      (v version)
      #:none
      "Output version information and exit"
      (format #t "$Id: xc 16871 2010-05-21 15:23:22Z azul $~%")
      (exit 0))
    (args:make-option
      (natural-language)
      #:none
      "Output numbers in natural language (eg. 'twenty-one')."
      (set! output-num (cut format #t "~R~%" <>)))
    (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
      (e errexit)
      #:none
      "Exit immediately (with non-zero) if evaluation of an expression fails"
      (set! handle-user-error error))
    (args:make-option
      (s suffix)
      (#:required "TYPE")
      "Set the system of suffixes used for the output (try 'help')"
      (output-suffix arg #t))
    (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 (implies -t)"
      (set! output-num output-time)
      (set! *show-colons* #f))
    (args:make-option
      (tw time-weeks)
      #:none
      "Output time with number of weeks (implies -t)"
      (set! output-num output-time)
      (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))))