TXR Examples

100 doors ↗

(defun hyaku-mai-tobira ()
  (let ((doors (vector 100)))
    (each ((i (range 0 99)))
      (each ((j (range i 99 (+ i 1))))
        (flip [doors j])))
    doors))

(each ((counter (range 1))
       (door (hyaku-mai-tobira)))
  (put-line `door @counter is @(if door "open" "closed")`))

The (range 99 -1 -1) expression produces a lazy list of integers from 99 down to -1. The mapcar* function lazily maps these numbers to strings, and the rest of the code treats this lazy list as text stream to process, extracting the numbers with some pattern matching cases and interpolating them into the song's text. Functional programming with lazy semantics meets text processing, pattern matching and here documents.

@(next :list @(mapcar* (fun tostring) (range 99 -1 -1)))
@(collect)
@number
@  (trailer)
@number_less_1
@  (cases)
@    (bind number "1")
@    (output)
1 bottle of beer one the wall
1 bottle of beer
@    (end)
@  (or)
@    (output)
@number bottles of beer one the wall
@number bottles of beer
@    (end)
@  (end)
@  (cases)
@    (bind number "0")
@    (output)
Go to the store and get some more,
99 bottles of beer on the wall!

@    (end)
@  (or)
@    (output)
Take one down and pass it around
@number_less_1 bottles of beer on the wall

@    (end)
@  (end)
@(end)

To make the song repeat indefinitely, change the first line to:

@(next :list @(mapcar* (fun tostring) (repeat (range 99 0 -1))))

Now it's processing an infinite lazy lists consisting of repetitions of the integer sequences 99 98 ... 0.

A+B ↗

$ txr -p '(+ (read) (read))'
1.2 2.3
3.5

ABC problem ↗

@(do
   (defvar blocks '((B O) (X K) (D Q) (C P) (N A) (G T) (R E) (T G)
                    (Q D) (F S) (J W) (H U) (V I) (A N) (O B) (E R)
                    (F S) (L Y) (P C) (Z M)))

   ;; Define and build hash which maps each letter that occurs in blocks
   ;; to a list of the blocks in which that letter occurs.

   (defvar alpha2blocks [hash-uni [group-by first blocks]
                                  [group-by second blocks]
                                  append])

   ;; convert, e.g. "abc" -> (A B C)
   ;; intern -- convert a string to an interned symbol "A" -> A
   ;; tuples -- turn string into 1-element tuples: "ABC" -> ("A" "B" "C")
   ;; square brackets around mapcar -- Lisp-1 style evaluation, allowing
   ;;   the intern function binding to be treated as a variable binding.

   (defun string-to-syms (str)
     [mapcar intern (tuples 1 (upcase-str str))])

   ;; Recursive part of algorithm working purely with Lisp symbols.
   ;; alpha -- single symbol denoting a letter
   ;; [alpha2blocks alpha] -- look up list of blocks for given letter
   ;; (memq item list) -- is item a member of list, under eq equality?
   ;; (remq item list) -- remove items from list which are eq to item.

   (defun can-make-word-guts (letters blocks)
     (cond
       ((null letters) t)
       ((null blocks) nil)
       (t (let ((alpha (first letters)))
            (each ((bl [alpha2blocks alpha]))
              (if (and (memq bl blocks)
                       (can-make-word-guts (rest letters)
                                           (remq bl blocks)))
                (return-from can-make-word-guts t)))))))

   (defun can-make-word (str)
     (can-make-word-guts (string-to-syms str) blocks)))
@(repeat)
@w
@(output)
>>> can_make_word("@(upcase-str w)")
@(if (can-make-word w) "True" "False")
@(end)
@(end)

Run:

$ cat abc-problem.data
a
bark
book
treat
common
squad
confuse
$ txr abc-problem.txr abc-problem.data
>>> can_make_word("A")
True
>>> can_make_word("BARK")
True
>>> can_make_word("BOOK")
False
>>> can_make_word("TREAT")
True
>>> can_make_word("COMMON")
False
>>> can_make_word("SQUAD")
True
>>> can_make_word("CONFUSE")
True

Accumulator factory ↗

Verbose

(defun accumulate (sum)
  (lambda (n)
    (inc sum n)))

;; test
(for ((f (accumulate 0)) num)
     ((set num (iread : : nil)))
     ((format t "~s -> ~s\n" num [f num])))
(exit 0)

Run:

$ txr accumulator-factory.tl
1
1 -> 1
2
2 -> 3
3
3 -> 6
400000000000000000000000000000000000000000000000000000000000000000000000
400000000000000000000000000000000000000000000000000000000000000000000000 -> 400000000000000000000000000000000000000000000000000000000000000000000006
5.3
5.3 -> 4e71
1e71
1e71 -> 5e71
[Ctrl-D][Enter]
$

Sugared

(let ((f (let ((sum 0)) (do inc sum @1))))
  (mapdo (do put-line `@1 -> @[f @1]`) (gun (iread : : nil))))

Output:

$ echo "1 2 3 4.5" | txr accumulator-factory2.tl 
1 -> 1
2 -> 3
3 -> 6
4.5 -> 10.5

Yield-based

Using the obtain/yield interface to delimited continuations, we can turn an imperative for loop into an accumulation function:

(defun accum ()
  (for ((sum (yield-from accum)))
       ()
       ((inc sum (yield-from accum sum)))))

(let ((f (obtain (accum))))
  (mapdo (do put-line `@1 -> @[f @1]`) (gun (iread : : nil))))

Output:

$ echo "1 2 3 4.5" | txr accumulator-factory2.tl 
1 -> 1
2 -> 3
3 -> 6
4.5 -> 10.5

OOP-based

OOP languages can use objects to simulate closures. In particular, function-objects which can be called as if they were functions, without any visible method being referenced. TXR Lisp supports functors as an expression of irony in language design. A structure object for which a method named lambda is defined can be used as function. Arguments applied to the objects are applied to lambda, preceded by the object itself as the leftmost argument:

(defstruct (accum count) nil
  (count 0))

(defmeth accum lambda (self delta)
  (inc self.count delta))

;; Identical test code to Yield-Based and Sugared, except for
;; the construction of the function object bound to variable f.
(let ((f (new (accum 0))))
  (mapdo (do put-line `@1 -> @[f @1]`) (gun (iread : : nil))))

Ackermann function ↗

Translation of Scheme

with memoization.

(defmacro defmemofun (name (. args) . body)
  (let ((hash (gensym "hash-"))
        (argl (gensym "args-"))
        (hent (gensym "hent-"))
        (uniq (copy-str "uniq")))
    ^(let ((,hash (hash :equal-based)))
       (defun ,name (,*args)
         (let* ((,argl (list ,*args))
                (,hent (inhash ,hash ,argl ,uniq)))
           (if (eq (cdr ,hent) ,uniq)
             (set (cdr ,hent) (block ,name (progn ,*body)))
             (cdr ,hent)))))))

(defmemofun ack (m n)
  (cond
    ((= m 0) (+ n 1))
    ((= n 0) (ack (- m 1) 1))
    (t (ack (- m 1) (ack m (- n 1))))))

(each ((i (range 0 3)))
  (each ((j (range 0 4)))
    (format t "ack(~a, ~a) = ~a\n" i j (ack i j))))

Output:

ack(0, 0) = 1
ack(0, 1) = 2
ack(0, 2) = 3
ack(0, 3) = 4
ack(0, 4) = 5
ack(1, 0) = 2
ack(1, 1) = 3
ack(1, 2) = 4
ack(1, 3) = 5
ack(1, 4) = 6
ack(2, 0) = 3
ack(2, 1) = 5
ack(2, 2) = 7
ack(2, 3) = 9
ack(2, 4) = 11
ack(3, 0) = 5
ack(3, 1) = 13
ack(3, 2) = 29
ack(3, 3) = 61
ack(3, 4) = 125

Algebraic data types ↗

TXR Lisp has structural pattern matching on objects of all kinds, including structures. We define a red-black tree structure like this, with a BOA constructor (by-order of arguments) for convenience:


(defstruct (rbnode color left right data) ()
  color
  left
  right
  data)

The empty tree case is handled by the nil symbol, so in terms of algebraic types, the tree is a sum of nil and the rbnode struct type, and that struct type is a product type of several properties. For the color slot, we use the keyword symbols :red and :black which needs not be declared anywhere. data can be any value. TXR Lisp's syntax for matching structures looks like this:


@(struct time year @y month @m)

This example matches a time structure instance, capturing the year as y and month as m. Structures aren't ordered tuples; they are clumps of of named slots, that cannot be accessed by position. This would break under inheritance, in particular multiple inheritance. Furthermore, variables have the @ sigil in most pattern matching constructs, because symbols without the sigil denote themselves as literal patterns. The pattern x matches the symbol x literally, and no other object. The pattern @x matches any object and captures it as x. These above features make it verbose and somewhat noisy to express pattern matching of our rbtree node. However, TXR Lisp's pattern matching sublanguage supports application-defined macro patterns, defined by the defmatch macro. With these we can achieve a shorthand notation which matches nodes as if they were ordered tuples, and which drops the sigils from variables.


(defmatch rb (color left right data)
  (flet ((var? (sym) (if (bindable sym) ^@,sym sym)))
    ^@(struct rbnode
        color ,(var? color)
        left ,(var? left)
        right ,(var? right)
        data ,(var? data))))

(defmatch red (left right data)
  ^@(rb :red ,left ,right ,data))

(defmatch black (left right data)
  ^@(rb :black ,left ,right ,data))

And with all the above, we can write the code like this:


(defun-match rb-balance
  ((@(or @(black @(red @(red a b x) c y) d z)
         @(black @(red a @(red b c x) x) d z)
         @(black a @(red @(red b c y) d z) x)
         @(black a @(red b @(red c d z) y) x)))
   (new (rbnode :red
                (new (rbnode :black a b x))
                (new (rbnode :black c d z))
                y)))
  ((@else) else))

(defun rb-insert-rec (tree x)
  (match-ecase tree
    (nil
     (new (rbnode :red nil nil x)))
    (@(rb color a b y)
     (cond
       ((< x y)
        (rb-balance (new (rbnode color (rb-insert-rec a) b y))))
       ((> x y)
        (rb-balance (new (rbnode color a (rb-insert-rec b) y))))
       (t tree)))))

(defun rb-insert (tree x)
  (match-case (rb-insert-rec tree x)
    (@(red a b y) (new (rbnode :black a b y)))
    (@else else)))

Insertion is split into two functions: a recursive one which works on its own, except that whenever the tree ends up with a red root, we would like to rewrite that node to a black one. We make the insertion function call the recursive one and then do this fix-up using pattern matching again.

Align columns ↗

@(collect)
@  (coll)@{item /[^$]+/}@(end)
@(end)
@; nc = number of columns
@; pi = padded items (data with row lengths equalized with empty strings)
@; cw = vector of max column widths
@; ce = center padding
@(bind nc @[apply max [mapcar length item]])
@(bind pi @(mapcar (op append @1 (repeat '("") (- nc (length @1)))) item))
@(bind cw @(vector-list
             (mapcar (op apply max [mapcar length @1])
                     ;; matrix transpose trick cols become rows:
                     [apply mapcar [cons list pi]])))
@(bind ns "")
@(output)
@  (repeat)
@    (rep :counter i)@{pi @[cw i]} @(end)
@  (end)
@  (repeat)
@    (rep :counter i)@{pi @(- [cw i])} @(end)
@  (end)
@  (repeat)
@    (rep :counter i)@\
     @{ns @(trunc (- [cw i] (length pi)) 2)}@\
     @{pi @(- [cw i] (trunc (- [cw i] (length pi)) 2))} @(end)
@  (end)
@(end)

$ txr align-columns.txr align-columns.dat 
Given      a          text       file   of     many      lines,     where    fields  within  a      line 
are        delineated by         a      single 'dollar'  character, write    a       program             
that       aligns     each       column of     fields    by         ensuring that    words   in     each 
column     are        separated  by     at     least     one        space.                               
Further,   allow      for        each   word   in        a          column   to      be      either left 
justified, right      justified, or     center justified within     its      column.                     
     Given          a       text   file     of      many     lines,    where  fields  within      a line 
       are delineated         by      a single  'dollar' character,    write       a program             
      that     aligns       each column     of    fields         by ensuring    that   words     in each 
    column        are  separated     by     at     least        one   space.                             
  Further,      allow        for   each   word        in          a   column      to      be either left 
justified,      right justified,     or center justified     within      its column.                     
  Given        a         text     file    of     many      lines,    where   fields  within    a    line
   are     delineated     by       a    single 'dollar'  character,  write      a    program
   that      aligns      each    column   of    fields       by     ensuring  that    words    in   each
  column      are     separated    by     at     least      one      space.     
 Further,    allow       for      each   word     in         a       column    to      be    either left
justified,   right    justified,   or   center justified   within     its    column.

Amb ↗

Delimited Continuations

Because we are using delimited continuations, we are able to confine the amb computation into a scope. To express this, we define an amb-scope operator which is just a syntactic sugar for using block to create a delimiting prompt whose name is amb-scope. Everything outside of an instance of this operator knows nothing about amb and is not involved in the backtracking flow at all. As far as the outside is concerned, the amb-scope block calculates something, terminates and returns a value, like any other ordinary Lisp form:

(defmacro amb-scope (. forms)
  ^(block amb-scope ,*forms))

Next, we define amb as a function. But first, a note about a convention: we are using the Lisp object nil not only to represent Boolean false, but also a failure. Thus (amb nil) fails. A nil return out of the entire amb-scope denotes overall failure. The function is very simple. It captures a single continuation and binds it to the cont variable, using the suspend macro. Then, it iterates over all of its arguments. Each argument which is nil is ignored. For any other value, the function effectively asks the question, "if, with this argument, I run my future computation to completion (i.e. back up to the delimiting contour defined by amb-scope) will the answer be a Boolean true?". It asks the question simply by invoking the continuation on the argument. If the answer is affirmative, then it breaks out of the loop and returns that argument value immediately. Otherwise the iteration continues with the next argument, to try a different alternative future. If the loop runs through to completion, then the function returns nil, indicating failure.

(defun amb (. args)
  (suspend amb-scope cont
    (each ((a args))
      (when (and a (call cont a))
        (return-from amb a)))))

And some test code:

Output:

$ txr -i amb.tl 
1> (amb-scope
     (let ((w1 (amb "the" "that" "a"))
           (w2 (amb "frog" "elephant" "thing"))
           (w3 (amb "walked" "treaded" "grows"))
           (w4 (amb "slowly" "quickly")))
       (amb (and (eql [w1 -1] [w2 0])
                 (eql [w2 -1] [w3 0])
                 (eql [w3 -1] [w4 0])))
       (list w1 w2 w3 w4)))
("that" "thing" "grows" "slowly")
2>

Pattern Language

This is not exactly the implementation of an operator, but a solution worth presenting. The language has the built in pattern matching and backtracking behavior suited for this type of text mining task. For convenience, we prepare the data in four files:

$ cat amb/set1
the
that
a
$ cat amb/set2
frog
elephant
thing
$ cat amb/set3
walked
treaded
grows
$ cat amb/set4
slowly
quickly

Then code is:

@(define first_last (first last whole))
@  (all)
@(skip :greedy)@{last 1}
@  (and)
@{first 1}@(skip)
@  (and)
@whole
@  (end)
@(end)
@(next "amb/set1")
@(skip)
@(first_last fi1 la1 w1)
@(next "amb/set2")
@(skip)
@(first_last la1 la2 w2)
@(next "amb/set3")
@(skip)
@(first_last la2 la3 w3)
@(next "amb/set4")
@(skip)
@(first_last la3 la4 w4)
@(output)
@w1 @w2 @w3 @w4
@(end)

Run:

$ ./txr amb.txr 
that thing grows slowly

As you can see, this has the "nondeterministic flavor" of Amb. The @(skip) directives"magically" skip over the lines of input that do not succeed. This example naturally handles empty strings, since the first_last function simply does not match such inputs. Here is how to embed the task's specific data in the code:

@(define first_last (first last whole))
@  (all)
@(skip :greedy)@{last 1}
@  (and)
@{first 1}@(skip)
@  (and)
@whole
@  (end)
@(end)
@(next :list ("the" "that" "a"))
@(skip)
@(first_last fi1 la1 w1)
@(next :list ("frog" "elephant" "thing"))
@(skip)
@(first_last la1 la2 w2)
@(next :list ("walked" "treaded" "grows"))
@(skip)
@(first_last la2 la3 w3)
@(next :list ("slowly" "quickly"))
@(skip)
@(first_last la3 la4 w4)
@(output)
@w1 @w2 @w3 @w4
@(end)

Anonymous recursion ↗

For the Y combinator approach in TXR, see the Y combinator task. The following easy transliteration of one of the Common Lisp solutions shows the conceptual and cultural compatibility between TXR Lisp macros and CL macros:

Translation of Common_Lisp

(defmacro recursive ((. parm-init-pairs) . body)
  (let ((hidden-name (gensym "RECURSIVE-")))
    ^(macrolet ((recurse (. args) ^(,',hidden-name ,*args)))
       (labels ((,hidden-name (,*[mapcar first parm-init-pairs]) ,*body))
         (,hidden-name ,*[mapcar second parm-init-pairs])))))

(defun fib (number)
  (if (< number 0)
    (error "Error. The number entered: ~a is negative" number)
    (recursive ((n number) (a 0) (b 1))
      (if (= n 0)
        a
        (recurse (- n 1) b (+ a b))))))

(put-line `fib(10) = @(fib 10)`)
(put-line `fib(-1) = @(fib -1)`))

Output:

$ txr anonymous-recursion.txr 
fib(10) = 55
txr: unhandled exception of type error:
txr: possibly triggered by anonymous-recursion.txr:9
txr: Error. The number entered: -1 is negative
Aborted (core dumped)

Apply a callback to an array ↗

Print 1 through 10 out of a vector, using prinl the callback, right from the system shell command prompt:

$ txr -e '[mapdo prinl #(1 2 3 4 5 6 7 8 9 10)]'
1
2
3
4
5
6
7
8
9
10

mapdo is like mapcar but doesn't accumulate a list, suitable for imperative programming situations when the function is invoked to perform a side effect. TXR extends Lisp list processing primitives to work with vectors and strings also, which is why mapdo cheerfully traverses a vector.

Arbitrary-precision integers (included)↗

@(bind (f20 l20 ndig)
       @(let* ((str (tostring (expt 5 4 3 2)))
               (len (length str)))
          (list [str :..20] [str -20..:] len)))
@(bind f20 "62060698786608744707")
@(bind l20 "92256259918212890625")
@(output)
@f20...@l20
ndigits=@ndig
@(end)

Output:

62060698786608744707...92256259918212890625
ndigits=183231

Arithmetic evaluation ↗

Use TXR text pattern matching to parse expression to a Lisp AST, then evaluate with eval:

@(next :args)
@(define space)@/ */@(end)
@(define mulop (nod))@\
   @(local op)@\
   @(space)@\
   @(cases)@\
     @{op /[*]/}@(bind nod @(intern op *user-package*))@\
   @(or)@\
     @{op /\//}@(bind (nod) @(list 'trunc))@\
   @(end)@\
   @(space)@\
@(end)
@(define addop (nod))@\
   @(local op)@(space)@{op /[+\-]/}@(space)@\
   @(bind nod @(intern op *user-package*))@\
@(end)
@(define number (nod))@\
  @(local n)@(space)@{n /[0-9]+/}@(space)@\
  @(bind nod @(int-str n 10))@\
@(end)
@(define factor (nod))@(cases)(@(expr nod))@(or)@(number nod)@(end)@(end)
@(define term (nod))@\
  @(local op nod1 nod2)@\
  @(cases)@\
    @(factor nod1)@\
    @(cases)@(mulop op)@(term nod2)@(bind nod (op nod1 nod2))@\
    @(or)@(bind nod nod1)@\
    @(end)@\
  @(or)@\
    @(addop op)@(factor nod1)@\
    @(bind nod (op nod1))@\
  @(end)@\
@(end)
@(define expr (nod))@\
  @(local op nod1 nod2)@\
  @(term nod1)@\
  @(cases)@(addop op)@(expr nod2)@(bind nod (op nod1 nod2))@\
  @(or)@(bind nod nod1)@\
  @(end)@\
@(end)
@(cases)
@  {source (expr e)}
@  (output)
source: @source
AST:    @(format nil "~s" e)
value:  @(eval e nil)
@  (end)
@(or)
@  (maybe)@(expr e)@(end)@bad
@  (output)
erroneous suffix "@bad"
@  (end)
@(end)

Run:

$  txr expr-ast.txr '3 + 3/4 * (2 + 2) + (4*4)'
source: 3 + 3/4 * (2 + 2) + (4*4)
AST:    (+ 3 (+ (trunc 3 (* 4 (+ 2 2))) (* 4 4)))
value:  19

Arrays ↗

TXR has two kinds of aggregate objects for sequences: lists and arrays. There is some syntactic sugar to manipulate them in the same way.

Literals

In the pattern matching language, there are no list literals. A list like ("a" "b" "c") is actually being evaluated, as can be seen in a directive such as @(bind (a b) (c "d")) where (c "d") is a list consisting of the value of variable c and the string "d". This is subject to destructuring and the two values are assigned to the variables a and b In TXR Lisp, there are literal lists introduced by a quote '(1 2 3 4). Vectors look like this: #(1 2 3 4).

Construction

Lists can be implicitly produced using pattern matching. Lists and vectors can be constructed using the functions of TXR Lisp. (vector 3) creates a vector of length three, whose elements are initialized to nil. (list 1 2 3) constructs the list (1 2 3).

Array Indexing Notation

The [] notation performs positional indexing on lists and arrays, which are both zero-based (element zero is the first element). Negative indices work from the tail of the list, whereby -1 denotes the last element of a sequence which has at least one element. Out of bounds access to arrays throws exceptions, but out of bounds access to lists produces nil. Out-of-bounds assignments are not permitted for either data type.

(defvar li (list 1 2 3))      ;; (1 2 3)
(defvar ve (vec 1 2 3)) ;; make vector #(1 2 3)
;; (defvar ve (vector 3)) ;; make #(nil nil nil)

[ve 0]    ;; yields 1
[li 0]    ;; yields 1
[ve -1]   ;; yields 3
[li 5]    ;; yields nil
[li -50]  ;; yields nil
[ve 50]   ;; error

(set [ve 2] 4) ;; changes vector to #(1 2 4).
(set [ve 3] 0) ;; error
(set [ve 3] 0) ;; error

Array Range Notation

Array range notation (slices) are supported, for both arrays and lists. An array range is a pair object denoted a .. b, which is a syntactic sugar for (cons a b). Therefore, a range constitutes a single argument in the bracket notation (allowing for straightforward future extension to multi-dimensional arrays indexing and slicing).

[ve 0..t]              ;; yield all of vector: t means "one position past last element"
[ve nil..nil]          ;; another way
[ve 1 3]               ;; yields #(2 3)
(set [ve 0..2] '(a b))  ;; changes vector to #(a b 3)
(set [ve 0..2] #(1 2))  ;; changes vector to #(1 2 3)
(set [li 0..1] nil)     ;; changes list to #(2 3), deleting 1.
(set [li t..t] '(4 5))  ;; changes list to #(2 3 4 5), appending (4 5)
(set [ve 1..2] '(0 0))  ;; changes vector to #(1 0 0 3), replacing 2 with 0 0

In The Pattern Language

In the TXR pattern language, there is an array indexing and slicing notation supported in output variables. The following assumes that variable a holds a list.

@(output)
here is a[0] left-adjusted in a 10 character field:

  @{a[0] 10}.

here are a[1] through a[3] joined with a colon,
right-adjusted in a 20 character field:

  @{a[1..4] ":" -20}
@(end)

A complete program which turns comma-separated into tab-separated, where the first and last field from each line are exchanged:

@(collect)
@line
@(bind f @(split-str line ","))
@(output)
@{f[-1]}@\t@{f[1..-1] "\t"}@\t@{f[0]}
@(end)
@(end)

Other Kinds of Objects

The [] notation also works with strings, including ranges and assignment to ranges. Hash tables can be indexed also, and the notation is meaningful for functions: [fun args ...] means the same thing as (call fun args ...), providing a Lisp-1 flavor within a Lisp-2 dialect.

Associative array/Iteration ↗

(defvarl h (hash))

(each ((k '(a b c))
       (v '(1 2 3)))
  (set [h k] v))

(dohash (k v h)
  (put-line `@k -> @v`))

Run:

$ txr hash.tl 
c -> 3
b -> 2
a -> 1

Balanced brackets ↗

@(define paren)@(maybe)[@(coll)@(paren)@(until)]@(end)]@(end)@(end)
@(do (defvar r (make-random-state nil))

     (defun generate-1 (count)
       (let ((bkt (repeat "[]" count)))
         (cat-str (shuffle bkt))))

     (defun generate-list (num count)
       [[generate tf (op generate-1 count)] 0..num]))
@(next :list @(generate-list 22 6))
@(output)
INPUT           MATCHED         REST
@(end)
@  (collect)
@    (all)
@parens
@    (and)
@{matched (paren)}@mismatched
@    (end)
@  (output)
@{parens 15} @{matched 15} @{mismatched 15}
@  (end)
@(end)

The recursive pattern function @(paren) gives rise to a grammar which matches parentheses:

@(define paren)@(maybe)[@(coll)@(paren)@(until)]@(end)]@(end)@(end)

A string of balanced parentheses is an optional unit (@(maybe) ... @(end)) that begins with [, followed by zero or more such balanced strings, followed by ]. Sample run:

$ ./txr paren.txr 
INPUT           MATCHED         REST
][[[]][][[]]                    ][[[]][][[]]   
[]][[]][][[]    []              ][[]][][[]     
[][[[[]]]]][    []              [[[[]]]]][     
][[][[]]][][                    ][[][[]]][][   
[[[][[]]][]]    [[[][[]]][]]                   
]][]][[[][[]                    ]][]][[[][[]   
[[]][]][[[]]    [[]]            []][[[]]       
]][]][]][[[[                    ]][]][]][[[[   
]][[]]][][[[                    ]][[]]][][[[   
]]]][[]][[[[                    ]]]][[]][[[[   
][[[[][[]]]]                    ][[[[][[]]]]   
][]][]]][[[[                    ][]][]]][[[[   
]][][[][][[]                    ]][][[][][[]   
]][][]][[][[                    ]][][]][[][[   
[][[]][]]][[    []              [[]][]]][[     
[[]]]]][[[[]    [[]]            ]]][[[[]       
]][[[[[[]]]]                    ]][[[[[[]]]]   
][][][[[]][]                    ][][][[[]][]   
[]][]][][][[    []              ][]][][][[     
]][[[][]][[]                    ]][[[][]][[]   
][[[[]]]][][                    ][[[[]]]][][   
[[]]]]][[][[    [[]]            ]]][[][[

Brace expansion ↗

The approach here is to parse the notation into a nested tree of strings. In the following diagram the -> arrow indicates that the tree on the left denotes the list of output strings on the right. A list with no operator symbol denotes catenation:

("foo" "bar")  -> ("foobar")

The / symbol (slash, usually denoting arithmetic division) denotes alternation:

(/ "foo" "bar") -> ("foo" "bar")
("inter" (/ "pol" "pret") "ation") -> ("interpolation" "interpretation")

This notation is processed by the bexp-expand function to produce the list of strings which it denotes. The bexp-parse function parses a string containing brace expansion into the above notation. The backslashes and edge cases are handled between the tokenizing and parsing. Backslashed characters are represented as tokens which include the backslash. Thus the \{ token compares unequal to { and isn't mistaken for it. These backslashed tokens just look like any other text that has no special meaning. The empty {} is handled as a token, but other cases of braces containing no commas are handled in the parser. When the parser has scanned a complete, valid brace that contains no comma, instead of generating a (/ ...) tree node from the content, it generates ("{" ... "}"), rendering the braces as literal strings. The ... content may contain / operators, as required. When the parser has scanned an incomplete brace, it puts out ("{" ...): the dangling brace is represented literally, followed by the items that have been parsed out. The comma elements are preserved in this case; the lack of a closing brace turns off their meaning. In the main case of a balanced brace with commas, the parsed out elements are split on the commas, which are removed, and that forms the arguments of / node.

;; API
(defun brace-expand (str)
  (bexp-expand (bexp-parse str)))

;; parser
(defstruct bexp-parse-ctx ()
  str
  toks)

(defun bexp-parse (str)
  (let ((ctx (new bexp-parse-ctx
                   str str
                   ;; tokenizer
                   toks (remqual "" (tok #/([{},]|{}|\\\\|\\.)/ t str)))))
    (build
      (whilet ((next (pop ctx.toks)))
        (add
          (if (equal next "{")
            (bexp-parse-brace ctx)
            next))))))

(defun bexp-parse-brace (ctx)
  (buildn
    (let ((orig-toks ctx.toks))
      (caseq (whilet ((next (pop ctx.toks)))
               (casequal next
                 ("{" (add (bexp-parse-brace ctx)))
                 ("}" (return :ok))
                 (t (add next))))
        (:ok
          (cond
            ((memqual "," (get))
             (flow (get)
               (split* @1 (op where (op equal ",")))
               (cons '/)))
            (t
              (add* "{")
              (add "}")
              (get))))
        (nil
          (add* "{")
          (get))))))

;; expander
(defun bexp-expand (tree : (path (new list-builder)))
  (build
    (match-case tree
      (() (add (cat-str path.(get))))
      (((/ . @alt) . @rest)
       (let ((saved-path path.(get)))
         (each ((elem alt))
           path.(oust saved-path)
           (pend (bexp-expand (cons elem rest) path)))))
      ((@(consp @succ) . @rest)
       (pend (bexp-expand (append succ rest) path)))
      ((@head . @rest)
       path.(add head)
       (pend (bexp-expand rest path))))))

;; Tests
(tprint (brace-expand "~/{Downloads,Pictures}/*.{jpg,gif,png}"))
(tprint (brace-expand "It{{em,alic}iz,erat}e{d,}, please."))
(tprint (brace-expand "{,{,gotta have{ ,\\, again\\, }}more }cowbell!"))
(tprint (brace-expand "{}} some }{,{\\\\{ edge, edge} \\,}{ cases, {here} \\\\\\\\\\}"))

Output:

~/Downloads/*.jpg
~/Downloads/*.gif
~/Downloads/*.png
~/Pictures/*.jpg
~/Pictures/*.gif
~/Pictures/*.png
Itemized, please.
Itemize, please.
Italicized, please.
Italicize, please.
Iterated, please.
Iterate, please.
cowbell!
more cowbell!
gotta have more cowbell!
gotta have\, again\, more cowbell!
{}} some }{,{\\ edge \,}{ cases, {here} \\\\\}
{}} some }{,{\\ edge \,}{ cases, {here} \\\\\}

Burrows–Wheeler transform ↗

We use the U+DC00 code point as the EOF sentinel. In TXR terminology, this code is called the pseudo-null. It plays a special significance in that when a NUL byte occurs in UTF-8 external data, TXR's decoder maps it the U+DC00 point. When a string containing U+DC00 is converted to UTF-8, that code becomes a NUL again.

(defvarl eof "\xDC00")

(defun bwt (str)
  (if (contains eof str)
    (error "~s: input may not contain ~a" %fun% eof))
  (let ((seof `@str@eof`))
    (flow 0..(len seof) (mapcar (op rot seof)) sort (mappend last))))

(defun ibwt (str)
  (let* ((ch (tuples 1 str))
         (row (sort ch)))
    (dotimes (i (pred (len str)))
      (upd row (mapcar append ch) nsort))
    [(find-if (op ends-with eof) row) 0..-1]))

At the REPL:

1> (bwt "^BANANA")
"BNN^AA\xDC00;A"
2> (ibwt *1)
"^BANANA"
3> (bwt "SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES")
"TEXYDST.E.IXIXIXXSSMPPS.B..E.\xDC00.UESFXDIIOIIITS"
4> (ibwt *3)
"SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES"

Caesar cipher ↗

The strategy here, one of many possible ones, is to build, at run time,the arguments to be passed to deffilter to construct a pair of filters enc and dec for encoding and decoding. Filters are specified as tuples of strings.

@(next :args)
@(cases)
@{key /[0-9]+/}
@text
@(or)
@  (throw error "specify <key-num> <text>")
@(end)
@(do
   (defvar k (int-str key 10)))
@(bind enc-dec
       @(collect-each ((i (range 0 25)))
          (let* ((p (tostringp (+ #\a i)))
                 (e (tostringp (+ #\a (mod (+ i k) 26))))
                 (P (upcase-str p))
                 (E (upcase-str e)))
            ^(((,p ,e) (,P ,E))
              ((,e ,p) (,E ,P))))))
@(deffilter enc . @(mappend (fun first) enc-dec))
@(deffilter dec . @(mappend (fun second) enc-dec))
@(output)
encoded: @{text :filter enc}
decoded: @{text :filter dec}
@(end)

Output:

$ ./txr caesar.txr 12 'Hello, world!'
encoded: Tqxxa, iadxp!
decoded: Vszzc, kcfzr!
$ ./txr caesar.txr 12 'Vszzc, kcfzr!'
encoded: Hello, world!
decoded: Jgnnq, yqtnf!

Call a foreign-language function ↗

This is the TXR Lisp interactive listener of TXR 176.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (with-dyn-lib nil
     (deffi strdup "strdup" str-d (str)))
#:lib-0177
2> (strdup "hello, world!")
"hello, world!"

The requirement to free the memory is taken care of the semantics of the str-d ("dynamic") variant of the str type. The semantics denotes the passage of ownership of malloc-ed memory across the interface. When the C-to-Lisp value conversion takes place on the return value, FFI releases the memory, knowing that it has received ownership of it from the function, which entails that responsibility. If the str type were used by mistake, a memory leak would result. There is no way to use the str family of types, yet do manual memory management; FFI manages automatically. Code that wants to manually manage a foreign resource referenced by pointer should use cptr or carray, depending on required semantics.

Call a function in a shared library ↗

Call `uname` on Linux

This is the TXR Lisp interactive listener of TXR 176.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (typedef utsarray (zarray 65 char))
#<ffi-type (zarray 65 char)>
2> (typedef utsname (struct utsname (sysname utsarray)
                                    (nodename utsarray)
                                    (release utsarray)
                                    (version utsarray)
                                    (machine utsarray)
                                    (domainname utsarray)))
#<ffi-type (struct utsname (sysname utsarray) (nodename utsarray) (release utsarray)
            (version utsarray) (machine utsarray) (domainname utsarray))>
3> (with-dyn-lib nil (deffi uname "uname" int ((ptr-out utsname))))
** warning: (expr-3:1) defun: redefining uname, which is a built-in defun
#:lib-0176
4> (let ((u (new utsname))) (prinl (uname u)) u)
0
#S(utsname sysname "Linux" nodename "zelenka" release "3.2.0-40-generic"
           version "#64-Ubuntu SMP Mon Mar 25 21:22:26 UTC 2013" machine "i686"
           domainname "(none)")

We use typedef to condense the declarations, much like in C. The FFI handles nested types like arrays in structures. The zarray type denotes null-terminated arrays. A zarray of char is specialized; it converts between Lisp strings (which use wide characters made of Unicode code points) and C char strings encoded in UTF-8. The argument of uname is (ptr-out utsname). The semantics of ptr-out in this situation is that FFI prepares a C version of the Lisp structure, but doesn't perform any conversions from Lisp to initialize it. This not only saves CPU cycles, but allows us to use a blank structure produced by (new utsname) all of whose slots are nil and so wouldn't convert to C character arrays anyway! The function is called, and then conversions out of the structure to the Lisp structure take place, filling its slots with string values. The nil argument in the with-dyn-lib macro causes the underlying implementation to call dlopen(NULL) to get access to the dynamic symbols available in the executable. We can use the name of a shared library instead, or a handle from TXR's dlopen library function.

Call an object method ↗

TXR Lisp method invocation syntax is obj.(method args...). Static methods are just functions that don't take an object as an argument. The above notation, therefore, normally isn't used, rather the functional square brackets: [obj.function args...]. The defstruct clause :method is equivalent to :function except that it requires at least one argument, the leftmost one denoting the object. The obj.(method args...) could be used to call a static function; it would pass obj as the leftmost argument. Vice versa, the square bracket call notation can be used to invoke a method; the object has to be manually inserted: [obj.function obj args...].

(defvarl thing-count 0)

(defstruct thing ()
  (call-count 0)

  (:init (me)
    (inc thing-count))
  (:function get-thing-count () thing-count)
  (:method get-call-count (me) (inc me.call-count)))

(let ((t1 (new thing))
      (t2 (new thing)))
  (prinl t1.(get-call-count)) ;; prints 1
  (prinl t1.(get-call-count)) ;; prints 2
  (prinl t1.(get-call-count)) ;; prints 3
  (prinl t2.(get-call-count)) ;; prints 1
  (prinl t2.(get-call-count)) ;; prints 2
  (prinl t2.(get-call-count)) ;; prints 3

  (prinl [t1.get-thing-count])  ;; prints 2
  (prinl [t2.get-thing-count])) ;; prints 2

Output:

Canonicalize CIDR ↗

The inaddr-str function in TXR Lisp parses IPv4 addresses, converting them to a sockaddr-in structure. If there is a slash notation present, it is recognized. The prefix value is validated and stored in the structure as the prefix value, and the numeric address is canonicalized to clear the irrelevant bits. Thus, the solution looks like this:

(defun cidr-canon (str)
  (let ((a (inaddr-str str)))
    `@(str-inaddr a.addr)/@{a.prefix}`))

Furthermore, the prefix notation can be condensed by removing unnecessary zeros. That is to say, 10.1.2.3/16 can be not just canonicalized to strip the irrelevant bits, but then shortened to 10.1/16. The built-in function inaddr-str-net will produce this condensed prefix notation:

(defun cidr-canon (str)
  (let ((a (inaddr-str str)))
    (str-inaddr-net a.addr a.prefix)))

This can be written using the flow macro:

(defun cidr-canon (str)
  (flow str
    inaddr-str
    (str-inaddr-net @1.addr @1.prefix)))

Cheryl's birthday ↗

(defun munge (groupfn selfn keepfn filfn data)
  (flow data
    (group-by groupfn)
    (mappend (iff (opip len (eq 2)) (opip cadr selfn list)))
    (keepfn (opip filfn (member @1 @@1)) data)))

(flow "May 15,     May 16,     May 19\n   \
       June 17,    June 18\n              \
       July 14,    July 16\n              \
       August 14,  August 15,  August 17\n"
  (remq #\,)
  read-objects
  (tuples 2)
  (munge second first remove-if first) prinl
  (munge second second keep-if second) prinl
  (munge first second keep-if second) prinl)

Output:

((July 14) (July 16) (August 14) (August 15) (August 17))
((July 16) (August 15) (August 17))
((July 16))

Classes ↗

(defstruct shape ()
  cached-area

  (:init (self)
    (put-line `@self is born!`))

  (:fini (self)
    (put-line `@self says goodbye!`))

  (:method area (self)
    (or self.cached-area
        (set self.cached-area self.(calc-area)))))

(defstruct circle shape
  (radius 1.0)

  (:method calc-area (self)
    (* %pi% self.radius self.radius)))

(defstruct square shape
  (length 1.0)

  (:method calc-area (self)
    (* self.length self.length)))

Output:

$ txr -i shapes.tl
1> (let ((s (new circle)))
     s.(area))
#S(circle cached-area nil radius nil) is born!
3.14159265358979
2> (sys:gc)
#S(circle cached-area 3.14159265358979 radius 1.0) says goodbye!
t
3>

Notes:

defstruct and new are macros which compile to invocations of the functions make-struct-type and make-struct.
The obj.fun(x, y) syntax is "halfway Lispified", and looks like obj.(fun x y). This denotes a method call: the function fun is retrieved from the object, and passed the arguments (obj x y).
The notation obj.[fun x y] is similar, but will '''not''' pass obj to fun; it is for calling static functions (class utility functions that don't require an instance).
a.b.c.d in TXR Lisp is a syntactic sugar for the expression (qref a b c d), where the elements may be compound expressions. Thus obj.(a b).c is (qref obj (a b) c).
There must be no whitespace around the dot: (a . b) is the consing dot whereas (a.b) is the syntax ((qref a b)).
Ambiguity with floating-point numbers isn't allowed. For instance, a.b.1 elicits an error from the parser (lexical scanner actually).

Closures/Value capture ↗

Sugared

(let ((funs (mapcar (ret (op * @@1 @@1)) (range 1 10))))
  [mapcar call [funs 0..-1]])

Output:

(1 4 9 16 25 36 49 64 81)

Desugared

Translation of Emacs Lisp

The explicit lambda structure here is much like the implicit ones in the "Sugared" example:

;; Dropping distracting "skip last" requirement
;; (not implemented in original Elisp either).
(mapcar 'call
       (mapcar (lambda ()
                (lambda () (* x x))) '(1 2 3 4 5 6 7 8 9 10)))

Delimited Continuations

In this interactive example, we capture delimited continuations inside a simple for loop. Because the variable binding environment is not necessarily in the stack which is captured, we rebind the loop variable.

This is the TXR Lisp interactive listener of TXR 124.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (let ((conts))
      (for ((i 0)) ((< i 10) (nreverse conts)) ((inc i))
        (let ((cap i))
           (push (block sqr
                    (suspend sqr f (op f nil))
                    (* cap cap))
                 conts))))
(#<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>
 #<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>
 #<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>
 #<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>
 #<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>)
2> (call (first *1))
0
3> (call (second *1))
1
4> (call (fifth *1))
16
5> (call [*1 4])
16
6> (call [*1 7])
49

The suspend operator suspends the execution of the sqr block, causing it to return the function (op f nil). The variable f represents the captured continuation as a function. Continuation functions take one mandatory argument. We don't need that here, hence the (op f nil) expression is returned: it curries the one arg continuation function f to a function with no arguments. The loop pushes these suspended continuations into a list, and then nreverse-s it. We then interactively call the continuations in the list. Whenever we call a continuation, the (block sqr ...) environment is restored. and the suspended computation inside the block resumes by returning out of the (suspend ...) form normally. The block then executes to completion, returning the (* cap cap) form's value. At that point, our call to the continuation terminates, yielding that value.

Combinations ↗

TXR has repeating and non-repeating permutation and combination functions that produce lazy lists. They are generic over lists, strings and vectors. In addition, the combinations function also works over hashes. Combinations and permutations are produced in lexicographic order (except in the case of hashes).

(defun comb-n-m (n m)
  (comb (range* 0 n) m))

(put-line `3 comb 5 = @(comb-n-m 5 3)`)

Run:

$ txr combinations.tl 
3 comb 5 = ((0 1 2) (0 1 3) (0 1 4) (0 2 3) (0 2 4) (0 3 4) (1 2 4) (1 3 4) (2 3 4))

Combinations with repetitions ↗

txr -p "(rcomb '(iced jam plain) 2)"

Output:


((iced iced) (iced jam) (iced plain) (jam jam) (jam plain) (plain plain))

----

txr -p "(length-list (rcomb '(0 1 2 3 4 5 6 7 8 9) 3))"

Output:

Comma quibbling ↗

(defun quib (list)
  (tree-bind (: last . lead) (reverse list)
    `{@{(nreverse lead) ", "}@(if lead " and ")@last}`))

Command-line arguments ↗

Command line arguments in TXR's pattern-based extraction language can be treated as the lines of a text stream, which is arranged using the directive @(next :args). Thus TXR's text parsing capabilities work over the argument list. This @(next :args) should be written as the first line of the TXR program, because TXR otherwise interprets the first argument as the name of an input file to open.

@(next :args)
@(collect)
@arg
@(end)
@(output)
My args are: {@(rep)@arg, @(last)@arg@(end)}
@(end)

$ ./txr args.txr
My args are: {}
$ ./txr args.txr 1
My args are: {1}
$ ./txr args.txr 1 2 3
My args are: {1, 2, 3}

Arguments are also available via two predefined variables: *full-args* and *args*, which are lists of strings, such that *args* is a suffic of *full-args*. *full-args* includes the arguments that were processed by TXR itself; *args* omits them. Here is an example program which requires exactly three arguments. Note how ldiff is used to compute the arguments that are processed by TXR (the interpreter name, any special arguments and script name), to print an accurate usage message.

(tree-case *args*
  ((a b c) (put-line "got three args, thanks!"))
  (else (put-line `usage: @(ldiff *full-args* *args*) <arg1> <arg2> <arg3>`)))

Output:

$ txr command-line-args.txr 1 2
usage: txr command-line-args.txr <arg1> <arg2> <arg3>
$ txr command-line-args.txr 1 2 3 4
usage: txr command-line-args.txr <arg1> <arg2> <arg3>
$ txr command-line-args.txr 1 2 3
got three args, thanks!

Comments ↗

@# old-style comment to end of line
@; new-style comment to end of line
@(bind a ; comment within expression
       "foo")

Compile-time calculation ↗

In TXR Lisp, the standard macro-time macro evaluates an expression at macro-expansion time, and replaces it by its result, which is then treated as a literal (because the macro inserts `quote` around it, if required). Such a macro is easy to implement in Common Lisp and similar dialects. The [https://www.nongnu.org/txr/txr-manpage.html#N-0131B069 documentation] provides a reference implementation which is easily ported. Example: provide a function buildinfo in the compiled program which returns the build machine name, and time and date of the compilation. A global variable which provides this value could similarly be defined:


(defun buildinfo ()
  (macro-time
    `Built by @{(uname).nodename} on @(time-string-local (time) "%c")`))

If we compile and disassemble the function, we see it just contains a canned literal:


3> (compile 'buildinfo)
#<vm fun: 0 param>
4> (disassemble *3)
data:
    0: buildinfo
    1: "Built by sun-go on Sat Oct  1 20:01:25 2022"
syms:
code:
    0: 8C000005 close t2 0 2 5 0 0 nil
    1: 00000002
    2: 00000000
    3: 00000002
    4: 10000401 end d1
    5: 10000002 end t2
instruction count:
    3
entry point:
    4
#<vm fun: 0 param>

Compound data type ↗

In TXR Lisp, a structure type can be created:

(defstruct point nil (x 0) (y 0))

If it is okay for the coordinates to be initialized to nil, it can be condensed to:

(defstruct point nil x y)

The nil denotes that a point has no supertype: it doesn't inherit from anything. This structure type can then be instantiated using the new macro (not the only way):

(new point)         ;; -> #S(point x 0 y 0)
(new point x 1)     ;; -> #S(point x 1 y 0)
(new point x 1 y 1) ;; -> #S(point x 1 y 1)

A structure can support optional by-order-of-arguments ("boa") construction by providing a "boa constructor". The defstruct syntactic sugar does this if a function-like syntax is used in place of the structure name:

(defstruct (point x y) nil (x 0) (y 0))

The existing construction methods continue to work, but in addition, this is now possible:

(new (point 3 4)) -> #S(point x 3 y 4)

Slot access syntax is supported. If variable p holds a point, then p.x designates the x slot, as a syntactic place which can be accessed and stored:

(defun displace-point-destructively (p delta)
  (inc p.x delta.x)
  (inc p.y delta.y))

Conditional structures ↗

In TXR, most directives are conditionals, because they specify some kind of match. Given some directive D, the underlying logic in the language is, roughtly, "if D does not match at the current position in the input, then fail, otherwise the input advances according to the semantics of D". An easy analogy to regular expressions may be drawn. The regex /abc/ means something like "if a doesn't match, then fail, otherwise consume a character and if b doesn't match, then fail, otherwise consume another character and if c doesn't match, then fail otherwise consume another character and succeed." The expressive power comes from, in part, not having to write all these decisions and book-keeping. The interesting conditional-like structures in TXR are the parallel directives, which apply separate clauses to the same input, and then integrate the results in various ways. For instance the choose construct will select, from among those clauses which match successfully, the one which maximizes or minimizes the length of an extracted variable binding:


@(choose :shortest x)
@x:@y
@(or)
@x<--@y
@(or)
@x+@y
@(end)

Suppose the input is something which can match all three patterns in different ways:

foo<--bar:baz+xyzzy

The outcome (with txr -B) will be:

x="foo"
y="bar:baz+xyzzy"

because this match minimizes the length of x. If we change this to :longest x, we get:

x="foo<--bar:baz"
y="xyzzy"

The cases, all and none directives most resemble control structures because they have short-circuiting behavior. For instance:

@(all)
@x:y@
@z<-@w
@(and)
@(output)
We have a match: (x, y, z, w) = (@x, @y, @z, @w).
@(end)
@(end)

If any subclause fails to match, then all stops processing subsequent clauses. There are subtleties though, because an earlier clause can produce variable bindings which are visible to later clauses. If previously bound variable is bound again, it must be to an identical piece of text:

@# match a line which contains some piece of text x
@# after the rightmost occurence of : such that the same piece
@# of text also occurs at the start of the line preceded by -->
@(all)
@*junk:@x
@(and)
-->@x@/.*/
@(end)

$ echo "-->asdfhjig:asdf" | txr -B weird.txr -
junk="-->asdfhjig"
x="asdf"
$ echo "-->assfhjig:asdf" | txr -B weird.txr -
false
$

Constrained genericity ↗

Macro wrapper for `defstruct`

We implement a food-box-defining macro, which checks at macro expansion time that the contained type is edible. The macro generates a structure of the specified name, which has a set-food method that additionally performs a run-time check against the exact variant of the edible type that was given to the macro.

(defmacro define-food-box (name food-type : supers . clauses)
  (unless (subtypep food-type 'edible)
    (error "~s requires edible type, not ~s" %fun% food-type))
  ^(defstruct ,name ,supers
     food
     (:method set-food (me food)
       (unless (typep food ',food-type)
         (error "~s: requires ~s object, not ~s" %fun% ',food-type food))
       (set me.food food))
     ,*clauses))

Instead of the type-based subtypep check, we could easily check for the existence of methods; e.g. test for the presence of a static slot using (static-slot-p food-type 'eat), or more specifically that it's a function: (functionp (static-slot food-type 'eat)). These tests will blow up if the macro's food-type argument isn't a struct type. In the interactive session below, we:

verify that define-food-box cannot be used with a type argument that isn't derived from edible
define the struct type edible and then one derived from it called perishable.
use define-food-box to define a box called fridge which holds perishable. This works because perishable is edible
create an instance of fridge and show that its set-food method doesn't take an integer, or an edible; only a perishable.

Output:

$ txr -i generic.tl 
This area is under 24 hour TTY surveillance.
1> (define-food-box fridge string)
** define-food-box requires edible type, not string
** during evaluation of form (error "~s requires edible type, not ~s"
                                    'define-food-box
                                    food-type)
** ... an expansion of (error "~s requires edible type, not ~s"
                              %fun% food-type)
** which is located at generic.tl:3
1> (defstruct edible ())
#<struct-type edible>
2> (defstruct perishable (edible))
#<struct-type perishable>
3> (define-food-box fridge perishable)
#<struct-type fridge>
4> (new fridge)
#S(fridge food nil)
5> *4.(set-food 42)
** (set-food fridge): requires perishable object, not 42
** during evaluation of form (error "~s: requires ~s object, not ~s"
                                    '(set-food fridge)
                                    'perishable
                                    food)
** ... an expansion of (error "~s: requires ~s object, not ~s"
                              %fun% 'perishable
                              food)
** which is located at expr-3:1
5> *4.(set-food (new edible))
** (set-food fridge): requires perishable object, not #S(edible)
** during evaluation of form (error "~s: requires ~s object, not ~s"
                                    '(set-food fridge)
                                    'perishable
                                    food)
** ... an expansion of (error "~s: requires ~s object, not ~s"
                              %fun% 'perishable
                              food)
** which is located at expr-3:1
5> *4.(set-food (new perishable))
#S(perishable)
6> *4
#S(fridge food #S(perishable))

Custom `defstruct` clause

Wrapping defstruct is a heavy-handed approach that may be difficult to retrofit into an existing code base. One possible issue is that two developers write such a macro, and then someone needs to use both of them for the same class. But each macro wants to write its own entire defstruct form. Here, we instead use a custom clause to inject the food slot, set-food method, and the static and dynamic checks. The mechanisms remain identical.

(define-struct-clause :food-box (food-type :form form)
  (unless (subtypep food-type 'edible)
    (compile-error form "~s requires edible type, not ~s" :food-box food-type))
  ^(food
    (:method set-food (me food)
      (unless (typep food ',food-type)
        (error "~s: requires ~s object, not ~s" %fun% ',food-type food))
      (set me.food food))))

Output:

$ txr -i generic.tl 
Apply today for a TXR credit card, and get 1MB off your next allocation.
1> (defstruct fridge ()
     (:food-box string))
** expr-1:1: defstruct: :food-box requires edible type, not string
1> (defstruct edible ())
#<struct-type edible>
2> (defstruct perishable (edible))
#<struct-type perishable>
3> (defstruct fridge ()
     (:food-box perishable))
#<struct-type fridge>
4> (new fridge)
#S(fridge food nil)
5> *4.(set-food 42)
** (set-food fridge): requires perishable object, not 42
** during evaluation of form (error "~s: requires ~s object, not ~s"
                                    '(set-food fridge)
                                    'perishable
                                    food)
** ... an expansion of (error "~s: requires ~s object, not ~s"
                              %fun% 'perishable
                              food)
** which is located at expr-3:1
5> *4.(set-food (new edible))
** (set-food fridge): requires perishable object, not #S(edible)
** during evaluation of form (error "~s: requires ~s object, not ~s"
                                    '(set-food fridge)
                                    'perishable
                                    food)
** ... an expansion of (error "~s: requires ~s object, not ~s"
                              %fun% 'perishable
                              food)
** which is located at expr-3:1
5> *4.(set-food (new perishable))
#S(perishable)

Count occurrences of a substring ↗

@(next :args)
@(do (defun count-occurrences (haystack needle)
       (for* ((occurrences 0)
              (old-pos 0)
              (new-pos (search-str haystack needle old-pos nil)))
             (new-pos occurrences)
             ((inc occurrences)
              (set old-pos (+ new-pos (length needle)))
              (set new-pos (search-str haystack needle old-pos nil))))))
@ndl
@hay
@(output)
@(count-occurrences hay ndl) occurrences(s) of @ndl inside @hay
@(end)

$ ./txr count-occurrences.txr "baba" "babababa"
2 occurence(s) of baba inside babababa
$ ./txr count-occurrences.txr "cat" "catapultcatalog"
2 occurence(s) of cat inside catapultcatalog

CRC-32 ↗

Standard Library

(crc32 "The quick brown fox jumps over the lazy dog")

Output:

1095738169

FFI access to Zlib

(with-dyn-lib "libz.so.1"
  (deffi zlib-crc32 "crc32" ulong (ulong str uint)))

Output:

$ txr -i crc32-zlib.tl 
1> (let ((s "The quick brown fox jumps over the lazy dog"))
      (zlib-crc32 0 s (coded-length s)))
1095738169

Note: coded-length gives UTF-8 length; len yields a code point count. Since this is an ASCII string, the two agree.

Lisp Code

(defvarl crc-tab
  #(#x00000000 #x77073096 #xee0e612c #x990951ba #x076dc419 #x706af48f
    #xe963a535 #x9e6495a3 #x0edb8832 #x79dcb8a4 #xe0d5e91e #x97d2d988
    #x09b64c2b #x7eb17cbd #xe7b82d07 #x90bf1d91 #x1db71064 #x6ab020f2
    #xf3b97148 #x84be41de #x1adad47d #x6ddde4eb #xf4d4b551 #x83d385c7
    #x136c9856 #x646ba8c0 #xfd62f97a #x8a65c9ec #x14015c4f #x63066cd9
    #xfa0f3d63 #x8d080df5 #x3b6e20c8 #x4c69105e #xd56041e4 #xa2677172
    #x3c03e4d1 #x4b04d447 #xd20d85fd #xa50ab56b #x35b5a8fa #x42b2986c
    #xdbbbc9d6 #xacbcf940 #x32d86ce3 #x45df5c75 #xdcd60dcf #xabd13d59
    #x26d930ac #x51de003a #xc8d75180 #xbfd06116 #x21b4f4b5 #x56b3c423
    #xcfba9599 #xb8bda50f #x2802b89e #x5f058808 #xc60cd9b2 #xb10be924
    #x2f6f7c87 #x58684c11 #xc1611dab #xb6662d3d #x76dc4190 #x01db7106
    #x98d220bc #xefd5102a #x71b18589 #x06b6b51f #x9fbfe4a5 #xe8b8d433
    #x7807c9a2 #x0f00f934 #x9609a88e #xe10e9818 #x7f6a0dbb #x086d3d2d
    #x91646c97 #xe6635c01 #x6b6b51f4 #x1c6c6162 #x856530d8 #xf262004e
    #x6c0695ed #x1b01a57b #x8208f4c1 #xf50fc457 #x65b0d9c6 #x12b7e950
    #x8bbeb8ea #xfcb9887c #x62dd1ddf #x15da2d49 #x8cd37cf3 #xfbd44c65
    #x4db26158 #x3ab551ce #xa3bc0074 #xd4bb30e2 #x4adfa541 #x3dd895d7
    #xa4d1c46d #xd3d6f4fb #x4369e96a #x346ed9fc #xad678846 #xda60b8d0
    #x44042d73 #x33031de5 #xaa0a4c5f #xdd0d7cc9 #x5005713c #x270241aa
    #xbe0b1010 #xc90c2086 #x5768b525 #x206f85b3 #xb966d409 #xce61e49f
    #x5edef90e #x29d9c998 #xb0d09822 #xc7d7a8b4 #x59b33d17 #x2eb40d81
    #xb7bd5c3b #xc0ba6cad #xedb88320 #x9abfb3b6 #x03b6e20c #x74b1d29a
    #xead54739 #x9dd277af #x04db2615 #x73dc1683 #xe3630b12 #x94643b84
    #x0d6d6a3e #x7a6a5aa8 #xe40ecf0b #x9309ff9d #x0a00ae27 #x7d079eb1
    #xf00f9344 #x8708a3d2 #x1e01f268 #x6906c2fe #xf762575d #x806567cb
    #x196c3671 #x6e6b06e7 #xfed41b76 #x89d32be0 #x10da7a5a #x67dd4acc
    #xf9b9df6f #x8ebeeff9 #x17b7be43 #x60b08ed5 #xd6d6a3e8 #xa1d1937e
    #x38d8c2c4 #x4fdff252 #xd1bb67f1 #xa6bc5767 #x3fb506dd #x48b2364b
    #xd80d2bda #xaf0a1b4c #x36034af6 #x41047a60 #xdf60efc3 #xa867df55
    #x316e8eef #x4669be79 #xcb61b38c #xbc66831a #x256fd2a0 #x5268e236
    #xcc0c7795 #xbb0b4703 #x220216b9 #x5505262f #xc5ba3bbe #xb2bd0b28
    #x2bb45a92 #x5cb36a04 #xc2d7ffa7 #xb5d0cf31 #x2cd99e8b #x5bdeae1d
    #x9b64c2b0 #xec63f226 #x756aa39c #x026d930a #x9c0906a9 #xeb0e363f
    #x72076785 #x05005713 #x95bf4a82 #xe2b87a14 #x7bb12bae #x0cb61b38
    #x92d28e9b #xe5d5be0d #x7cdcefb7 #x0bdbdf21 #x86d3d2d4 #xf1d4e242
    #x68ddb3f8 #x1fda836e #x81be16cd #xf6b9265b #x6fb077e1 #x18b74777
    #x88085ae6 #xff0f6a70 #x66063bca #x11010b5c #x8f659eff #xf862ae69
    #x616bffd3 #x166ccf45 #xa00ae278 #xd70dd2ee #x4e048354 #x3903b3c2
    #xa7672661 #xd06016f7 #x4969474d #x3e6e77db #xaed16a4a #xd9d65adc
    #x40df0b66 #x37d83bf0 #xa9bcae53 #xdebb9ec5 #x47b2cf7f #x30b5ffe9
    #xbdbdf21c #xcabac28a #x53b39330 #x24b4a3a6 #xbad03605 #xcdd70693
    #x54de5729 #x23d967bf #xb3667a2e #xc4614ab8 #x5d681b02 #x2a6f2b94
    #xb40bbe37 #xc30c8ea1 #x5a05df1b #x2d02ef8d))

(defun crc32 (buf)
  (let ((crc #xffffffff)
        (l (len buf)))
    (each ((i 0..l))
      (set crc (logxor [crc-tab (logand (logxor crc [buf i]) #xff)]
                       (ash crc -8))))
    (logxor crc #xffffffff)))

Output:

$ ./txr -i crc.tl 
warning: (crc.tl:46) defun: redefining crc32, which is a built-in defun
1> (crc32 (buf-str "The quick brown fox jumps over the lazy dog"))
1095738169

CSV data manipulation ↗

@(coll)@{name /[^,]+/}@(end)
@(collect :vars (value sum))
@  (bind sum 0)
@  (coll)@{value /[^,]+/}@(set sum @(+ sum (int-str value)))@(end)
@(end)
@(output)
@  (rep)@name,@(last)SUM@(end)
@  (repeat)
@    (rep)@value,@(last)@sum@(end)
@  (end)
@(end)

CSV to HTML translation ↗

Simple

@(collect)
@char,@speech
@(end)
@(output :filter :to_html)
<table>
@  (repeat)
  <tr>
     <td>@char</td>
     <td>@speech</td>
  </tr>
@  (end)
</table>
@(end)

$ txr csv.txr  csv.txt

<table>
  <tr>
     <td>Character</td>
     <td>Speech</td>
  </tr>
  <tr>
     <td>The multitude</td>
     <td>The messiah! Show us the messiah!</td>
  </tr>
  <tr>
     <td>Brians mother</td>
     <td>&lt;angry&gt;Now you listen here! He's not the messiah; he's a very naughty boy! Now go away!&lt;/angry&gt;</td>
  </tr>
  <tr>
     <td>The multitude</td>
     <td>Who are you?</td>
  </tr>
  <tr>
     <td>Brians mother</td>
     <td>I'm his mother; that's who!</td>
  </tr>
  <tr>
     <td>The multitude</td>
     <td>Behold his mother! Behold his mother!</td>
  </tr>
</table>

With Styling

@(collect)
@char,@speech
@(end)
@(output :filter :to_html)
<style type="text/css">
tr.odd td {
  background-color: #CC9999; color: black;
}
tr.even td {
  background-color: #9999CC; color: black;
}
th {
  background-color: #99CC99; color: black;
}
</style>
<table>
@  (repeat :counter row)
  <tr class="@(if (evenp row) 'even 'odd)">
     <td>@char</td>
     <td>@speech</td>
  </tr>
@  (first)
  <tr>
     <th>@char</th>
     <th>@speech</th>
  </tr>
@  (end)
</table>
@(end)

$ txr csv2.txr  csv.txt

<style type="text/css">
tr.odd td {
  background-color: #CC9999; color: black;
}
tr.even td {
  background-color: #9999CC; color: black;
}
th {
  background-color: #99CC99; color: black;
}
</style>
<table>
  <tr>
     <th>Character</th>
     <th>Speech</th>
  </tr>
  <tr class="odd">
     <td>The multitude</td>
     <td>The messiah! Show us the messiah!</td>
  </tr>
  <tr class="even">
     <td>Brians mother</td>
     <td>&lt;angry&gt;Now you listen here! He's not the messiah; he's a very naughty boy! Now go away!&lt;/angry&gt;</td>
  </tr>
  <tr class="odd">
     <td>The multitude</td>
     <td>Who are you?</td>
  </tr>
  <tr class="even">
     <td>Brians mother</td>
     <td>I'm his mother; that's who!</td>
  </tr>
  <tr class="odd">
     <td>The multitude</td>
     <td>Behold his mother! Behold his mother!</td>
  </tr>
</table>

Currying ↗

Note: many solutions for this task are conflating currying with partial application. Currying converts an N-argument function into a cascade of one-argument functions. The curry operator doesn't itself bind any arguments; no application is going on. The relationship between currying and partial application is that partial application occurs when the cascade is unraveled as arguments are applied to it: each successive one-argument call in the cascade binds an argument, and when all the arguments are bound, the value of the original function over those arguments is computed. TXR Lisp has an operator called op for partial application. Of course, partial application is done with lambdas under the hood; the operator generates lambdas. Its name is inspired by the same-named operators featured in the Goo language, and in the Common Lisp library cl-op. References: Goo op: [http://people.csail.mit.edu/jrb/goo/manual.46/goomanual_15.html] cl-op: [https://cliki.net/cl-op] TXR's op is quite different in that it uses numbered arguments, has some additional features, and is accompanied by a "zoo" of related operators which share its partial application syntax, providing various useful derived behaviors. A two-argument function which subtracts is arguments from 10, and then subtracts five:

(op - 10 @1 @2 5)

TXR Lisp doesn't have a predefined function or operator for currying. A function can be manually curried. For instance, the three-argument named function: (defun f (x y z) (* (+ x y) z)) can be curried by hand to produce a function g like this:

(defun g (x)
  (lambda (y)
    (lambda (z)
       (* (+ x y) z))))

Or, by referring to the definition of f:

(defun g (x)
  (lambda (y)
    (lambda (z)
       (f x y z))))

Since a three-argument function can be defined directly, and has advantages like diagnosing incorrect calls which pass fewer than three or more than three arguments, currying is not useful in this language. Similar reasoning applies as given in the "Why not real currying/uncurrying?" paragraph under the Design Rationale of Scheme's SRFI 26.

Delegates ↗

;; TXR Lisp's :delegate implementation is hard delegation: the indicated
;; delegate object must exist and take the method call. To do soft
;; delegation, we develop a macro (delegate-or-fallback x y z)
;; which chooses x if x is an object which supports a z method,
;; or else chooses y.

(defun delegate-or-fallback-impl (del-inst fb-inst required-meth)
  (let (del-type)
    (if (and (structp del-inst)
             (set del-type (struct-type del-inst))
             (static-slot-p del-type required-meth)
             (functionp (static-slot del-type required-meth)))
      del-inst
      fb-inst)))

(defmacro delegate-or-fallback (delegate-expr fallback-obj : required-meth)
  ^(delegate-or-fallback-impl ,delegate-expr ,fallback-obj ',required-meth))

;; With the above, we can use the defstruct delegate clause syntax:
;; 
;;  (:delegate source-method (obj) target-obj target-method)
;;
;; which writes a delegate method called source-method, that delegates
;; to target-method on target-obj. We calculate target-obj using
;; our macro and ensure that the delegator itself imlpements target-method.

(defstruct delegator ()
  delegate
  (:delegate operation (me) (delegate-or-fallback me.delegate me thing) thing)

  (:method thing (me)
    "default implementation"))

(defstruct delegate ()
  (:method thing (me)
    "delegate implementation"))

;; Tests:

;; no delegate
(prinl (new delegator).(operation))

;; struct delegate, but not with thing method
(prinl (new delegator delegate (new time)).(operation))

;; delegate with thing method
(prinl (new delegator delegate (new delegate)).(operation))

Output:

"default implementation"
"default implementation"
"delegate implementation"

Detect division by zero ↗

@(do (defun div-check (x y)
       (catch (/ x y)
         (numeric_error (msg)
           'div-check-failed))))
@(bind good @(div-check 32 8))
@(bind bad @(div-check 42 0))

Run:

$ txr -B division-by-zero.txr
good="4.0"
bad="div-check-failed"

Determine if only one instance is running ↗

Microsoft Windows

;;; Define some typedefs for clear correspondence with Win32
(typedef HANDLE cptr)
(typedef LPSECURITY_ATTRIBUTES cptr)
(typedef WINERR (enum WINERR ERROR_SUCCESS
                             (ERROR_ALREADY_EXISTS 183))) 
(typedef BOOL (enum BOOL FALSE TRUE))
(typedef LPCWSTR wstr)

;;; More familiar spelling for null pointer.
(defvarl NULL cptr-null)

;;; Define access to foreign functions.
(with-dyn-lib "kernel32.dll"
  (deffi CreateMutex "CreateMutexW" HANDLE (LPSECURITY_ATTRIBUTES BOOL LPCWSTR))
  (deffi CloseHandle "CloseHandle" BOOL (HANDLE))
  (deffi GetLastError "GetLastError" WINERR ()))

;;; Now, the single-instance program:
(defvar m (CreateMutex NULL 'TRUE "ApplicationName"))

(unless (eq (GetLastError) 'ERROR_ALREADY_EXISTS)
  ;; mutual exclusion here
  )
 
(CloseHandle m)

DNS query ↗

At the listener prompt:

This is the TXR Lisp interactive listener of TXR 283.
Quit with :quit or Ctrl-D on an empty line. Ctrl-X ? for cheatsheet.
TXR's no-spray organic production means every bug is carefully removed by hand.
1> (flow (getaddrinfo "www.kame.net") (mapcar .(str-addr)) uniq)
("210.155.141.200" "2001:2f0:0:8800::1:1" "2001:2f0:0:8800:226:2dff:fe0b:4311")

Empty string ↗

Pattern Matching

@(bind a "")

If a is unbound, a binding is created, containing the empty string. If a is already bound, bind succeeds if a contains the empty string, and the pattern matching continues at the next directive. Or else a failure occurs, triggering backtracking behavior.

TXR Lisp

(defvarl a "")

(if (equal a "")
  (format t "empty string\n"))

(set a "nonempty")

(if (zerop (length a))
  (format t "guess what?\n"))

Environment variables ↗

TXR can treat the environment vector as text stream:

@(next :env)
@(collect)
@VAR=@VAL
@(end)

A recently added gather directive is useful for extracting multiple items of data from an unordered stream of this kind (not only the environment vector):

@(next :env)
@(gather)
HOME=@home
USER=@user
PATH=@path
@(end)

What if some of the variables might not exist? Gather has some discipline for that. The following means that three variables are required (the gather construct fails if they are not found), but shell is optional with a default value of /bin/sh if it is not extracted from the data:

@(next :env)
@(gather :vars (home user path (shell "/bin/sh")))
HOME=@home
USER=@user
PATH=@path
SHELL=@shell
@(end)

From TXR Lisp, the environment is available via the (env) function, which returns a raw list of "name=value strings. The (env-hash) function returns a hash from environment keys to their values.

$ ./txr -p "(mapcar (env-hash) '(\"HOME\" \"USER\" \"PATH\"))"
("/home/kaz" "kaz" "/home/kaz/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/games:/home/kaz/bin"

Here, the hash is being used as a function to filter several environment keys to their values via mapcar. Platform note: On POSIX, environment variables, which are extracted using extern char **environ are assumed to contain UTF-8. On Windows, the GetEnvironmentStringsW function is used to obtain the environment vector as wide character data.

Evaluate binomial coefficients ↗

nCk is a built-in function, along with the one for permutations, nPk:

$ txr -p '(n-choose-k 20 15)'
15504

$ txr -p '(n-perm-k 20 15)'
20274183401472000

Exceptions ↗

Here is a complicated exceptions example straight from the manual. This is a deliberately convoluted way to process input consisting of lines which have the form:

{monkey | gorilla | human} <name>

Some custom exceptions are defined, and arranged into a hierarchy via @(defex) directives. An exception precedence hierarchy is established. A gorilla is a kind of ape, and an ape is a kind of primate. A monkey is a kind of primate, and so is a human. In the main @(collect) clause, we have a try protect block in which we collect three different cases of primate. For each one, we throw an exception with the primate type symbol, and its name. This is caught in the catch clause as the argument "name". The catch clause performs another pattern match, @kind @name. This match is being applied to exactly the same line of data for which the exception was thrown (backtracking!). Therefore the @kind variable will collect the primate type. However @name already has a binding since it is the argument of the catch. Since it has a value already, that value has to match what is in the data. Of course, it does since it was derived from that data. The data and the variable unify against each other.

@(defex gorilla ape primate)
@(defex monkey primate)
@(defex human primate)
@(collect)
@(try)
@(cases)
gorilla @name
@(throw gorilla name)
@(or)
monkey @name
@(throw monkey name)
@(or)
human @name
@(throw human name)
@(end)@#cases
@(catch primate (name))
@kind @name
@(output)
we have a primate @name of kind @kind
@(end)@#output
@(end)@#try
@(end)@#collect

Sample interactive run. Here the input is typed into standard input from the tty. The output is interleaved with the input, since TXR doesn't reads ahead only as much data as it needs.

$ txr primates.txr -
[TTY]human Harry
[TTY]gorilla Gordon
[OUT]we have a primate Harry of kind human
[TTY]monkey Mike
[OUT]we have a primate Gordon of kind gorilla
[TTY][Ctrl-D/EOF]
[OUT]we have a primate Mike of kind monkey

Exceptions/Catch an exception thrown in a nested call ↗

@(defex u0)
@(defex u1)
@(define baz (x))
@  (cases)
@    (bind x "0")
@    (throw u0 "text0")
@  (or)
@    (bind x "1")
@    (throw u1 "text1")
@  (end)
@(end)
@(define bar (x))
@  (baz x)
@(end)
@(define foo ())
@  (next :list @'("0" "1"))
@  (collect)
@num
@    (try)
@      (bar num)
@    (catch u0 (arg))
@      (output)
caught u0: @arg
@      (end)
@    (end)
@  (end)
@(end)
@(foo)

Run:

$ txr except.txr 
caught u0: text0
txr: unhandled exception of type u1:
txr: text1
txr: during evaluation at exceptions.txr:9 of form (throw u1 "text1")
$ echo $?
1

Extend your language ↗

Translation of CommonLisp

(defmacro if2 (cond1 cond2 both first second . neither)
  (let ((res1 (gensym))
        (res2 (gensym)))
    ^(let ((,res1 ,cond1)
           (,res2 ,cond2))
       (cond ((and ,res1 ,res2) ,both)
             (,res1             ,first)
             (,res2             ,second)
             (t                 ,*neither)))))

Factorial ↗

Built-in

Via nPk function:

$ txr -p '(n-perm-k 10 10)'
3628800

Functional

$ txr -p '[reduce-left * (range 1 10) 1]'
3628800

File input/output ↗

As a character string:

(let ((var (file-get-string "input.txt")))
  (file-put-string "output.txt" var))

As a list of lines:

(let ((var (file-get-lines "input.txt")))
  (file-put-lines "output.txt" var))

Find limit of recursion ↗

(set-sig-handler sig-segv
  (lambda (signal async-p) (throw 'out)))

(defvar *count* 0)

(defun recurse ()
  (inc *count*)
  (recurse))

(catch (recurse)
  (out () (put-line `caught segfault!\nreached depth: @{*count*}`)))

Output:

$ txr limit-of-recursion.tl
caught segfault!
reached depth: 10909

Find URI in text ↗

@(define path (path))@\
  @(local x y)@\
  @(cases)@\
    (@(path x))@(path y)@(bind path `(@x)@y`)@\
  @(or)@\
    @{x /[.,;'!?][^ \t\f\v]/}@(path y)@(bind path `@x@y`)@\
  @(or)@\
    @{x /[^ .,;'!?()\t\f\v]/}@(path y)@(bind path `@x@y`)@\
  @(or)@\
    @(bind path "")@\
  @(end)@\
@(end)
@(define url (url))@\
  @(local proto domain path)@\
  @{proto /[A-Za-z]+/}://@{domain /[^ \/\t\f\v]+/}@\
  @(cases)/@(path path)@\
    @(bind url `@proto://@domain/@path`)@\
  @(or)@\
    @(bind url `@proto://@domain`)@\
  @(end)@\
@(end)
@(collect)
@  (all)
@line
@  (and)
@     (coll)@(url url)@(end)@(flatten url)
@  (end)
@(end)
@(output)
LINE
    URLS
----------------------
@  (repeat)
@line
@    (repeat)
    @url
@    (end)
@  (end)
@(end)

Test file:

$ cat url-data 
Blah blah http://en.wikipedia.org/wiki/Erich_Kästner_(camera_designer). (Handled by http://mediawiki.org/).
Confuse the parser: http://en.wikipedia.org/wiki/-)
ftp://domain.name/path(balanced_brackets)/foo.html
ftp://domain.name/path(balanced_brackets)/ending.in.dot.
ftp://domain.name/path(unbalanced_brackets/ending.in.dot.
leading junk ftp://domain.name/path/embedded?punct/uation.
leading junk ftp://domain.name/dangling_close_paren)

Run:

$ txr url.txr url-data 
LINE 
    URLS
----------------------
Blah blah http://en.wikipedia.org/wiki/Erich_Kästner_(camera_designer). (Handled by http://mediawiki.org/).
    http://en.wikipedia.org/wiki/Erich_Kästner_(camera_designer)
    http://mediawiki.org/
Confuse the parser: http://en.wikipedia.org/wiki/-)
    http://en.wikipedia.org/wiki/-
ftp://domain.name/path(balanced_brackets)/foo.html
    ftp://domain.name/path(balanced_brackets)/foo.html
ftp://domain.name/path(balanced_brackets)/ending.in.dot.
    ftp://domain.name/path(balanced_brackets)/ending.in.dot
ftp://domain.name/path(unbalanced_brackets/ending.in.dot.
    ftp://domain.name/path
leading junk ftp://domain.name/path/embedded?punct/uation.
    ftp://domain.name/path/embedded?punct/uation
leading junk ftp://domain.name/dangling_close_paren)
    ftp://domain.name/dangling_close_paren

First-class functions ↗

Translation of Racket

Translation notes: we use op to create cube and inverse cube anonymously and succinctly. chain composes a variable number of functions, but unlike compose, from left to right, not right to left.

(defvar funlist [list sin
                      cos
                      (op expt @1 3)])

(defvar invlist [list asin
                      acos
                      (op expt @1 (/ 1 3))])

(each ((f funlist) (i invlist))
  (prinl [(chain f i) 0.5]))

Output:

0.5
0.5
0.5
0.5

First-class functions/Use numbers analogously ↗

This solution seeks a non-strawman interpretation of the exercise: to treat functions and literal numeric terms under the same operations. We develop a three-argument function called binop whose argument is an ordinary function which works on numbers, and two arithmetic arguments which are any combination of functions or numbers. The functions may have any arity from 0 to 2. The binop functions handles all the cases. The basic rules are:

When all required arguments are given to a function, it is expected that a number will be produced.

Zero-argument functions are called to force a number out of them.

When operands are numbers or zero-argument functions, a numeric result is calculated.

Otherwise the operation is a functional combinator, returning a function.

(defun binop (numop x y)
  (typecase x
    (number (typecase y
              (number [numop x y])
              (fun (caseql (fun-fixparam-count y)
                     (0 [numop x [y]])
                     (1 (ret [numop x [y @1]]))
                     (2 (ret [numop x [y @1 @2]]))
                     (t (error "~s: right argument has too many params"
                               %fun% y))))
              (t (error "~s: right argument must be function or number"
                        %fun% y))))
    (fun (typecase y
           (number (caseql (fun-fixparam-count x)
                     (0 [numop [x] y])
                     (1 (ret [numop [x @1] y]))
                     (2 (ret [numop [x @1 @2] y]))
                     (t (error "~s: left argument has too many params"
                               %fun% x))))
           (fun (macrolet ((pc (x-param-count y-param-count)
                                ^(+ (* 3 ,x-param-count) ,y-param-count)))
                   (caseql* (pc (fun-fixparam-count x) (fun-fixparam-count y))
                     (((pc 0 0)) [numop [x] [y]])
                     (((pc 0 1)) (ret [numop [x] [y @1]]))
                     (((pc 0 2)) (ret [numop [x] [y @1 @2]]))
                     (((pc 1 0)) (ret [numop [x @1] [y]]))
                     (((pc 1 1)) (ret [numop [x @1] [y @1]]))
                     (((pc 1 2)) (ret [numop [x @1] [y @1 @2]]))
                     (((pc 2 0)) (ret [numop [x @1 @2] [y]]))
                     (((pc 2 1)) (ret [numop [x @1 @2] [y @1]]))
                     (((pc 2 2)) (ret [numop [x @1 @2] [y @1 @2]]))
                     (t (error "~s: one or both arguments ~s and ~s\ \
                               have excess arity" %fun% x y)))))))
      (t (error "~s: left argument must be function or number"
              %fun% y))))

(defun f+ (x y) [binop + x y])
(defun f- (x y) [binop - x y])
(defun f* (x y) [binop * x y])
(defun f/ (x y) [binop / x y])

With this, the following sort of thing is possible:

1> [f* 6 4]  ;; ordinary arithmetic.
24
2> [f* f+ f+]  ;; product of additions
#<interpreted fun: lambda (#:arg-1-0062 #:arg-2-0063 . #:arg-rest-0061)>
3> [*2 10 20]  ;; i.e. (* (+ 10 20) (+ 10 20)) -> (* 30 30)
900
4> [f* 2 f+]   ;; doubled addition
#<interpreted fun: lambda (#:arg-1-0017 #:arg-2-0018 . #:arg-rest-0016)>
5> [*4 11 19]  ;; i.e. (* 2 (+ 11 19))
60
6> [f* (op f+ 2 @1) (op f+ 3 @1)]
#<interpreted fun: lambda (#:arg-1-0047 . #:arg-rest-0046)>
7> [*6 10 10]  ;; i.e. (* (+ 2 10) (+ 3 10)) -> (* 12 13)
156

So with these definitions, we can solve the task like this, which demonstrates that numbers and functions are handled by the same operations:

(let* ((x 2.0)
       (xi 0.5)
       (y 4.0)
       (yi 0.25)
       (z (lambda () (f+ x y))) ;; z is obviously function
       (zi (f/ 1 z)))           ;; also a function
  (flet ((multiplier (a b) (op f* @1 (f* a b))))
    (each ((n (list x y z))
           (v (list xi yi zi)))
      (prinl [[multiplier n v] 42.0]))))

Output:

42.0
42.0
42.0

Fixed length records ↗

80 Column Task

At the shell prompt:


$ txr -e '(let ((buf (make-buf 80))
                (nread 80))
            (while (eql nread 80)
              (set nread (fill-buf-adjust buf))
              (buf-set-length buf 80)
              (put-buf (nreverse buf))))' < infile80.bin > outfile80.bin
$ dd if=outfile80.bin cbs=80 conv=unblock
8.........7.........6.........5.........4.........3.........2.........1...1 eniL
                                                                          2 eniL
                                                                          3 eniL
                                                                          4 eniL

                                                                          6 eniL
                                                                          7 eniL
............................................................8 enil detnednI
NIGRAM TR                                                                 9 eniL

1+1 records in
1+1 records out
725 bytes copied, 8.658e-05 s, 8.4 MB/s

This handles a final bit that is shorter than 80. When buf-set-length sets the buffer size back to 80, zero padding is applied. The zero-padded record is reversed.

Forth Blocks Task

Encoding

The following program is called forth-enblock.tl:

(typedef forth-line (array 64 bchar))

(let ((lno 0)
      (blanks (make-buf 64 #\space)))
  (whilet ((line (get-line)))
    (put-obj (fmt "~-64,64a" line) (ffi forth-line))
    (inc lno))
  (while (plusp (mod (pinc lno) 16))
    (put-buf blanks)))

Output:

$ txr forth-enblock.tl  < forth-enblock.tl > forth-enblock.blk
$ xxd forth-enblock.blk 
00000000: 2874 7970 6564 6566 2066 6f72 7468 2d6c  (typedef forth-l
00000010: 696e 6520 2861 7272 6179 2036 3420 6263  ine (array 64 bc
00000020: 6861 7229 2920 2020 2020 2020 2020 2020  har))           
00000030: 2020 2020 2020 2020 2020 2020 2020 2020                  
00000040: 2020 2020 2020 2020 2020 2020 2020 2020                  
00000050: 2020 2020 2020 2020 2020 2020 2020 2020                  
00000060: 2020 2020 2020 2020 2020 2020 2020 2020                  
00000070: 2020 2020 2020 2020 2020 2020 2020 2020                  
00000080: 286c 6574 2028 286c 6e6f 2030 2920 2020  (let ((lno 0)   
[... snip ...]
000003e0: 2020 2020 2020 2020 2020 2020 2020 2020                  
000003f0: 2020 2020 2020 2020 2020 2020 2020 2020

Decoding

This is forth-deblock.tl

(typedef forth-block (array 16 (array 64 bchar)))

(defsymacro fbsz (sizeof forth-block))

(let* ((buf (make-buf fbsz))
       (block-view (carray-buf buf (ffi forth-block)))
       (nread fbsz))
  (while (eql fbsz nread)
    (set nread (fill-buf-adjust buf))
    (when (plusp nread)
      (buf-set-length buf fbsz #\space)
      (each ((row [block-view 0]))
        (put-line (trim-right #/ +/ row))))))

Output:

$ txr forth-deblock.tl < forth-enblock.blk
(typedef forth-line (array 64 bchar))

(let ((lno 0)
      (blanks (make-buf 64 #\space)))
  (whilet ((line (get-line)))
    (put-obj (fmt "~-64,64a" line) (ffi forth-line))
    (inc lno))
  (while (plusp (mod (pinc lno) 16))
    (put-buf blanks)))

FizzBuzz ↗

$ txr -p "(mapcar (op if @1 @1 @2) (repeat '(nil nil fizz nil buzz fizz nil nil fizz buzz nil fizz nil nil fizzbuzz)) (range 1 100))"

Flatten a list ↗

An important builtin.

@(bind foo ((1) 2 ((3 4) 5) ((())) (((6))) 7 8 ()))
@(bind bar foo)
@(flatten bar)

Run:

$ txr -a 5 flatten.txr  # show variable bindings in array notation to depth 5
foo[0][0]="1"
foo[1]="2"
foo[2][0][0]="3"
foo[2][0][1]="4"
foo[2][1]="5"
foo[4][0][0][0]="6"
foo[5]="7"
foo[6]="8"
bar[0]="1"
bar[1]="2"
bar[2]="3"
bar[3]="4"
bar[4]="5"
bar[5]="6"
bar[6]="7"
bar[7]="8"

Floyd's triangle ↗

(defun flotri (n)
  (let* ((last (trunc (* n (+ n 1)) 2))
         (colw (mapcar [chain tostring length]
                       (range (- last n -1) last)))
         (x 0))
    (each ((r (range* 0 n)))
      (each ((c (range 0 r)))
        (format t " ~*a" [colw c] (inc x)))
      (put-line))))

(defun usage (msg)
  (put-line `error: @msg`)
  (put-line `usage:\n@(ldiff *full-args* *args*) <smallish-positive-integer>`)
  (exit 1))

(tree-case *args*
  ((num blah . etc) (usage "too many arguments"))
  ((num) (flotri (int-str num)))
  (() (usage "need an argument")))

Output:

$ txr floyds-triangle.tl
error: need an argument
usage:
txr floyds-triangle.tl <smallish-positive-integer>
$ txr floyds-triangle.txr 1 2
error: too many arguments
usage:
txr floyds-triangle.tl <smallish-positive-integer>
$ txr floyds-triangle.tl 5
  1
  2  3
  4  5  6
  7  8  9 10
 11 12 13 14 15
$ txr floyds-triangle.tl 14
  1
  2  3
  4  5  6
  7  8  9 10
 11 12 13 14 15
 16 17 18 19 20 21
 22 23 24 25 26 27 28
 29 30 31 32 33 34 35 36
 37 38 39 40 41 42 43 44  45
 46 47 48 49 50 51 52 53  54  55
 56 57 58 59 60 61 62 63  64  65  66
 67 68 69 70 71 72 73 74  75  76  77  78
 79 80 81 82 83 84 85 86  87  88  89  90  91
 92 93 94 95 96 97 98 99 100 101 102 103 104 105

Function definition ↗

In TXR, there are pattern functions which are predicates that perform pattern matching and variable capture. A call to this type of function call can specify unbound variables. If the function succeeds, it can establish bindings for those variables. Here is how to make a pattern function that multiplies, and call it. To multiply the numbers, we break out of the pattern language and invoke Lisp evaluation: @(* a b)

@(define multiply (a b out))
@(bind out @(* a b))
@(end)
@(multiply 3 4 result)

$ txr -B multiply.txr
result="12"

In the embedded Lisp dialect, it is possible to write an ordinary function that returns a value:

(defun mult (a b) (* a b))
  (put-line `3 * 4 = @(mult 3 4)`)

$ txr multiply.tl
3 * 4 = 12

Gamma function ↗

Taylor Series

Translation of Ada

Separator commas in numeric tokens are supported only as of TXR 283.

(defun gamma (x)
  (/ (rpoly (- x 1.0)
            #( 1.00000,00000,00000,00000  0.57721,56649,01532,86061
              -0.65587,80715,20253,88108 -0.04200,26350,34095,23553
               0.16653,86113,82291,48950 -0.04219,77345,55544,33675
              -0.00962,19715,27876,97356  0.00721,89432,46663,09954
              -0.00116,51675,91859,06511 -0.00021,52416,74114,95097
               0.00012,80502,82388,11619 -0.00002,01348,54780,78824
              -0.00000,12504,93482,14267  0.00000,11330,27231,98170
              -0.00000,02056,33841,69776  0.00000,00061,16095,10448
               0.00000,00050,02007,64447 -0.00000,00011,81274,57049
               0.00000,00001,04342,67117  0.00000,00000,07782,26344
              -0.00000,00000,03696,80562  0.00000,00000,00510,03703
              -0.00000,00000,00020,58326 -0.00000,00000,00005,34812
               0.00000,00000,00001,22678 -0.00000,00000,00000,11813
               0.00000,00000,00000,00119  0.00000,00000,00000,00141
              -0.00000,00000,00000,00023  0.00000,00000,00000,00002))))

(each ((i 1..11))
  (put-line (pic "##.######" (gamma (/ i 3.0)))))

Output:

Stirling

(defun gamma (x)
  (* (sqrt (/ (* 2 %pi%)
              x))
     (expt (/ x %e%) x)))

(each ((i 1..11))
  (put-line (pic "##.######" (gamma (/ i 3.0)))))

Output:

Lanczos

Translation of Haskell

The Haskell version calculates the natural log of the gamma function, which is why the function is called gammaln; we correct that here by calling exp:

(defun gamma (x)
  (let* ((cof #(76.18009172947146 -86.50532032941677
                24.01409824083091 -1.231739572450155
                0.001208650973866179 -0.000005395239384953))
         (ser0 1.000000000190015)
         (x55 (+ x 5.5))
         (tmp (- x55 (* (+ x 0.5) (log x55))))
         (ser (+ ser0 (sum [mapcar / cof (succ x)]))))
    (exp (- (log (/ (* 2.5066282746310005 ser) x)) tmp))))

(each ((i (rlist 0.1..1.0..0.1 2..10)))
  (put-line (pic "##.# ######.######" i (gamma i))))

Output:

 0.1      9.513508
 0.2      4.590844
 0.3      2.991569
 0.4      2.218160
 0.5      1.772454
 0.6      1.489192
 0.7      1.298055
 0.8      1.164230
 0.9      1.068629
 1.0      1.000000
 2.0      1.000000
 3.0      2.000000
 4.0      6.000000
 5.0     24.000000
 6.0    120.000000
 7.0    720.000000
 8.0   5040.000000
 9.0  40320.000000
10.0 362880.000000

From Wikipedia Python code. Output is identical to above.

(defun gamma (x)
  (if (< x 0.5)
    (/ %pi%
       (* (sin (* %pi% x))
          (gamma (- 1 x))))
    (let* ((cof #(676.5203681218851 -1259.1392167224028
                  771.32342877765313 -176.61502916214059
                  12.507343278686905 -0.13857109526572012
                  9.9843695780195716e-6 1.5056327351493116e-7))
           (ser0 0.99999999999980993)
           (z (pred x))
           (tmp (+ z (len cof) -0.5))
           (ser (+ ser0 (sum [mapcar / cof (succ z)]))))
      (* (sqrt (* 2 %pi%))
         (expt tmp (+ z 0.5))
         (exp (- tmp))
         ser))))

(each ((i (rlist 0.1..1.0..0.1 2..10)))
  (put-line (pic "##.# ######.######" i (gamma i))))

Generic swap ↗

TXR Lisp has a swap macro operator. However, an operator just like it can be user-defined (let us call it swp). Moreover, the user-defined version can be just as robust, ensuring once-only evaluation for both expressions. Swapping can be achieved with pset and rotate also. We won't use these in the following examples.

Naive macro

This allows multiple evaluation of the argument expressions.

(defmacro swp (left right)
  (with-gensyms (tmp)
    ^(let ((,tmp ,left))
       (set ,left ,right
            ,right ,tmp))))

Using `placelet`

TXR Lisp's placelet macro allows the programmer to bind a lexically scoped alias for a syntactic place. The place can be accessed and stored through this alias. Yet, the place is evaluated only once. With placelet it is easy to write many kinds of place-manipulating macros very simply. We can write a robust swap which evaluates the left and right expressions just once:

(defmacro swp (left right)
  (with-gensyms (tmp lpl rpl)
    ^(placelet ((,lpl ,left)
                (,rpl ,right))
       (let ((,tmp ,lpl))
         (set ,lpl ,rpl
              ,rpl ,tmp)))))

Using place expanders

Finally, the following is closely based on how swap is actually implemented in TXR Lisp's library. This explicitly uses the general mechanism for handling places, on which placelet is based also:

(defmacro swp (left right :env env)
  (with-gensyms (tmp)
    (with-update-expander (l-getter l-setter) left env
      (with-update-expander (r-getter r-setter) right env
        ^(let ((,tmp (,l-getter)))
           (,l-setter (,r-getter))
           (,r-setter ,tmp))))))

with-update-expander is a macro which writes code for accessing and updating a place, and makes that code available as local macros. The result is wrapped around the body of code passed to the macro; the body can access these functions, using a backquote to insert the symbols which refer to them. For instance the macro call (,l-getter) expands to code which accesses the prior value of the left place, and (,r-setter ,tmp) stores the value of the temporary variable into the right place.

Globally replace text in several files ↗

Extraction Language

@(next :args)
@(repeat)
@file
@(next `@file`)
@(freeform)
@(coll :gap 0)@notmatch@{match /Goodbye, London!/}@(end)@*tail@/\n/
@(output `@file.tmp`)
@(rep)@{notmatch}Hello, New York!@(end)@tail
@(end)
@(do @(rename-path `@file.tmp` file))
@(end)

Run:

$ cat foo.txt
aaaGoodbye, London!aaa
Goodbye, London!
$ cat bar.txt
aaaGoodbye, London!aaa
Goodbye, London!
$ txr replace-files.txr foo.txt bar.txt
$ cat foo.txt
aaaHello, New York!aaa
Hello, New York!
$ cat bar.txt
aaaHello, New York!aaa
Hello, New York!

Run, with no directory permissions:

$ chmod a-w .
$ txr replace-files.txr foo.txt bar.txt
txr: unhandled exception of type file_error:
txr: could not open foo.txt.tmp (error 13/Permission denied)

TXR Lisp

(each ((fname *args*))
  (let* ((infile (open-file fname))
         (outfile (open-file `@fname.tmp` "w"))
         (content (get-string infile))
         (edited (regsub #/Goodbye, London/ "Hello, New York" content)))
    (put-string edited outfile)
    (rename-path `@fname.tmp` fname)))

Greatest common divisor ↗

$ txr -p '(gcd (expt 2 123) (expt 6 49))'
562949953421312

Hailstone sequence ↗

@(do (defun hailstone (n)
       (cons n
             (gen (not (eq n 1))
                  (set n (if (evenp n)
                           (trunc n 2)
                           (+ (* 3 n) 1)))))))
@(next :list @(mapcar* (fun tostring) (hailstone 27)))
27
82
41
124
@(skip)
8
4
2
1
@(eof)
@(do (let ((max 0) maxi)
       (each* ((i (range 1 99999))
               (h (mapcar* (fun hailstone) i))
               (len (mapcar* (fun length) h)))
         (if (> len max)
           (progn
             (set max len)
             (set maxi i))))
       (format t "longest sequence is ~a for n = ~a\n" max maxi)))

$ txr -l hailstone.txr
longest sequence is 351 for n = 77031

Handle a signal ↗

(set-sig-handler sig-int
                 (lambda (signum async-p)
                   (throwf 'error "caught signal ~s" signum)))

(let ((start-time (time)))
  (catch (each ((num (range 1)))
           (format t "~s\n" num)
           (usleep 500000))
    (error (msg)
           (let ((end-time (time)))
             (format t "\n\n~a after ~s seconds of execution\n"
                     msg (- end-time start-time))))))

Run:

$ txr handle-a-signal.tl
1
2
3
4
5
6
7
8
9
10
11
12
^C

caught signal 2 after 6 seconds of execution

range generates a range of integers as a lazy list, which is infinite if the endpoint argument is omitted. We walk this infinite list using each like any other list.

Hash from two arrays ↗

One-liner, using quasiquoted hash syntax

$ txr -p  '^#H(() ,*[zip #(a b c) #(1 2 3)])))'
#H(() (c 3) (b 2) (a 1))

One-liner, using `hash-construct` function

$ txr -p  '(hash-construct nil [zip #(a b c) #(1 2 3)])))'
#H(() (c 3) (b 2) (a 1))

Explicit construction and stuffing

(defun hash-from-two (vec1 vec2 . hash-args)
  (let ((table (hash . hash-args)))
    (mapcar (do sethash table) vec1 vec2)
    table))

(prinl (hash-from-two #(a b c) #(1 2 3)))

$ ./txr hash-from-two.tl
#H(() (c 3) (b 2) (a 1))

Hash join ↗

Generic hash join. Arguments left-key and right-key are functions applied to the elements of the left and right sequences to retrieve the join key.

(defvar age-name '((27 Jonah)
                   (18 Alan)
                   (28 Glory)
                   (18 Popeye)
                   (28 Alan)))

(defvar nemesis-name '((Jonah Whales)
                       (Jonah Spiders)
                       (Alan Ghosts)
                       (Alan Zombies)
                       (Glory Buffy)))

(defun hash-join (left left-key right right-key)
  (let ((join-hash [group-by left-key left])) ;; hash phase
    (append-each ((r-entry right))            ;; join phase
      (collect-each ((l-entry [join-hash [right-key r-entry]]))
        ^(,l-entry ,r-entry)))))

(format t "~s\n" [hash-join age-name second nemesis-name first])

Output:

$ txr hash-join.tl
(((27 Jonah) (Jonah Whales)) ((27 Jonah) (Jonah Spiders)) ((18 Alan) (Alan Ghosts)) ((28 Alan) (Alan Ghosts)) ((18 Alan) (Alan Zombies)) ((28 Alan) (Alan Zombies)) ((28 Glory) (Glory Buffy)))

Hello world/Graphical ↗

Microsoft Windows

(with-dyn-lib "user32.dll"
  (deffi messagebox "MessageBoxW" int (cptr wstr wstr uint)))

(messagebox cptr-null "Hello" "World" 0) ;; 0 is MB_OK

Hello world/Newline omission ↗

Possible using access to standard output stream via TXR Lisp:

$ txr -e '(put-string "Goodbye, world!")'
Goodbye, world!$

Here document ↗

TXR was originally conceived out of the need to have "there documents": parse a document and extract variables, but in a style similar to generation of here documents. Here doc output was added later. We use @(maybe)/@(or)/@(end) to set up some default values for variables which are overridden from the command line. Unification fails for an overridden variable, which is why we have to separate out the bind directives into the branches of a maybe. By passing the script to txr using -f we can pass additional command arguments to the resulting script which are interpreted by txr.

#!/usr/bin/txr -f
@(maybe)
@(bind USER "Unknown User")
@(or)
@(bind MB "???")
@(end)
@(output)
Dear @USER

Your are over your disk quota by @MB megabytes.

The Computer
@(end)

Test runs


$ ./quota.txr -DMB=20
Dear Unknown User

Your are over your disk quota by 20 megabytes.

The Computer
$ ./quota.txr -DUSER=Bob
Dear Bob

Your are over your disk quota by ??? megabytes.

The Computer
$ ./quota.txr -DUSER=Bob -DMB=15
Dear Bob

Your are over your disk quota by 15 megabytes.

The Computer

Unbound variables throw exceptions:


$ txr -c '@(output)
@FOO
@(end)'
txr: unhandled exception of type query_error:
txr: (cmdline:2) bad substitution: FOO

Higher-order functions ↗

lambda passed to mapcar with environment capture:

@(bind a @(let ((counter 0))
            (mapcar (lambda (x y) (list (inc counter) x y))
                    '(a b c) '(t r s))))
@(output)
@  (repeat)
@    (rep)@a:@(last)@a@(end)
@  (end)
@(end)

1:a:t
2:b:r
3:c:s

Host introspection ↗

Interactive session: Which word? Pointer size or size of int? Let's get both:

This is the TXR Lisp interactive listener of TXR 177.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (sizeof (ptr char))
8
2> (sizeof int)
4

Endianness: what we can do is put the integer 1 into a buffer as a uint32, the 32 bit unsigned integer type in the local representation. We then retrieve it as a le-uint32: little-endian uint32:

3> (ffi-put 1 (ffi uint32))
#b'01000000'
4> (ffi-get *3 (ffi le-uint32))
1

The extracted value 1 matches, so the machine must be little endian. Here is a transcript from a big-endian PPC64 machine:

1> (ffi-put 1 (ffi uint32))
#b'00000001'
2> (ffi-get *1 (ffi le-uint32))
16777216

No match, so big endian.

Increment a numerical string ↗

Two implementations of what the task says: incrementing a numerical string. (Not: converting a string to a number, then incrementing the number, then converting back to string.)

TXR Lisp

@(do (defun inc-num-str (str-in)
       (let ((len (length str-in))
             (str (copy-str str-in)))
         (for ((i (- len 1)))
              ((>= i 0) `1@str`)
              ((dec i))
           (if (<= (inc [str i]) #\9)
             (return str)
             (set [str i] #\0))))))
@(bind a @(inc-num-str "9999"))
@(bind b @(inc-num-str "1234"))

$ ./txr -B incnum.txr 
a="10000"
b="1235"

No TXR Lisp

@(deffilter incdig ("0" "1") ("1" "2") ("2" "3") ("3" "4") ("4" "5")
                   ("5" "6") ("6" "7") ("7" "8") ("8" "9"))
@(define increment (num out))
@  (local prefix dig junk)
@  (next :string num)
@  (cases)
9
@    (bind out "10")
@  (or)
@*{prefix}@{dig /[0-8]/}
@    (bind out `@prefix@{dig :filter incdig}`)
@  (or)
@*{prefix}9
@    (bind out `@{prefix :filter (:fun increment)}0`)
@  (or)
@junk
@    (throw error `bad input: @junk`)
@  (end)
@(end)
@in
@(increment in out)

$ echo 1 | ./txr -B incnum.txr -
input="1"
result="2"
$ echo 123 | ./txr -B incnum.txr -
input="123"
result="124"
$ echo 899999 | ./txr -B incnum.txr -
input="899999"
result="900000"
$ echo 999998 | ./txr -B incnum.txr -
input="999998"
result="999999"
$ echo 999999 | ./txr -B incnum.txr -
input="999999"
result="1000000"

Inheritance/Single ↗

Inheritance among symbolic exception tags

@(defex cat animal)
@(defex lab dog animal)
@(defex collie dog)

The second line is a shorthand which defines a lab to be a kind of dog, and at the same time a dog to be a kind of animal. If we throw an exception of type lab, it can be caught in a catch for a dog or for an animal. Continuing with the query:

@(try)
@  (throw lab "x")
@(catch animal (arg))
@(end)

Output:

Test:

$ txr dog-cat.txr
arg="x"

OOP Inheritance in TXR Lisp

(defstruct animal nil
  name
  (:method get-name (me)
    (if me.name me.name (error `get-name: animal @me has no name`)))
  (:method speak (me stream)
    (error "abstract animal cannot speak")))

(defstruct dog animal
  (:method speak (me : (stream *stdout*))
    (put-line `@{me.(get-name)}: bark!` stream)))

(defstruct cat animal
  (:method speak (me : (stream *stdout*))
    (put-line `@{me.(get-name)}: meow!` stream)))

(defstruct lab dog)

(defstruct collie dog)

(let ((pet1 (new collie name "Lassie"))
      (pet2 (new cat name "Max")))
  pet1.(speak)
  pet2.(speak))

Output:

Lassie: bark!
Max: meow!

JSON ↗

Built-In

TXR has built in JSON support. The TXR Lisp syntax supports JSON literals, which are prefixed with #J.

1> #J{"foo" : true, [1, 2, "bar", false] : null}
#H(() ("foo" t) (#(1.0 2.0 "bar" nil) null))

JSON objects become hash tables, and arrays become vectors. The JSON keywords true, false and null become Lisp symbols t, nil and null. The above #J syntax is a true hash table literal; it isn't an expression which has to be evaluated to construct the object. Quasiquoting is supported over this syntax, in two usefully different ways. In quasiquoted JSON, an interpolated values are indicated not by the usual unquoting comma, but a tilde. If we place the quasiquoting circumflex after the #J, just before the JSON syntax, then we get a form of quasiquote which interpolates values into the implied data structure. The syntax is transliterated into an invocation of a macro called json, which produces code to construct the object, with the dynamic values inserted into it:

1> (let ((str "hello"))
     #J^{~str : 42})
#H(() ("hello" 42.0))

If the syntax is externally quasiquoted, such as by the circumflex being placed just before the #J or else by the JSON occurring inside a larger Lisp quasiquote, then the literal syntax itself is being quasiquoted. The result of evaluating the quasiquote isn't the object, but the syntax itself, which when evaluated again produces the object:

1> (let ((str "hello"))
     ^#J{~str : 42})
#J{"hello":42}
2> (eval *1)
#H(() ("hello" 42.0))

The get-json and put-json functions are the basic interface for reading JSON from a stream, and sending data to a stream in JSON format. Surrounding these core functions are a number of convenience functions. For instance file-get-json reads a JSON file and returns the data structure, and tojson returns an object as a JSON character string.

1> (file-get-json "/usr/share/iso-codes/json/iso_15924.json")
#H(() ("15924" #(#H(() ("name" "Adlam") ("alpha_4" "Adlm") ("numeric" "166"))
                 #H(() ("name" "Afaka") ("alpha_4" "Afak") ("numeric" "439"))

                 [ ... SNIP ... ]

                 #H(() ("name" "Code for uncoded script") ("alpha_4" "Zzzz") ("numeric" "999")))))

JSON is printed in a "native" formatting by default:

2> (put-jsonl *1)
{"15924":[{"name":"Adlam","alpha_4":"Adlm","numeric":"166"},{"name":"Afaka","alpha_4":"Afak","numeric":"439"},
          {"name":"Caucasian Albanian","alpha_4":"Aghb","numeric":"239"},
          {"name":"Ahom, Tai Ahom","alpha_4":"Ahom","numeric":"338"},{"name":"Arabic","alpha_4":"Arab","numeric":"160"},

          [ ... SNIP ... ]

          {"name":"Code for undetermined script","alpha_4":"Zyyy","numeric":"998"},
          {"name":"Code for uncoded script","alpha_4":"Zzzz","numeric":"999"}]}
t

With the special variable *print-json-format* we can get the de-facto standard formatting.

3> (let ((*print-json-format* :standard))
     (put-jsonl *1))
{
  "15924" : [
    {
      "name" : "Adlam",
      "alpha_4" : "Adlm",
      "numeric" : "166"
    },
    {
      "name" : "Afaka",
      "alpha_4" : "Afak",
      "numeric" : "439"
    },
    {
      "name" : "Caucasian Albanian",
      "alpha_4" : "Aghb",
      "numeric" : "239"
    },

    [ ... SNIP ... ]

    {
      "name" : "Code for uncoded script",
      "alpha_4" : "Zzzz",
      "numeric" : "999"
    }
  ]
}
t

The *read-bad-json* variable controls whether the parser is tolerant toward superfluous commas:

4> (get-json "[1, 2, 3,]")
** syntax error: read: string: errors encountered
4> (let ((*read-bad-json* t)) 
     (get-json "[1, 2, 3,]"))
#(1.0 2.0 3.0)

Numbers must be floating-point in order to convert to JSON:

5> (put-jsonl #(1 2 3))
[** print: invalid object 1 in JSON
** during evaluation at expr-7:1 of form (put-jsonl #(1 2 3))
5> (put-jsonl #(1. 2. 3.))
[1,2,3]
t

This rigidity prevents errors in applications like saving some integer in JSON which unexpectedly comes back as a floating-point value, not necessarily equal to that integer.

From Scratch JSON Parsing in Pattern Language

The following implements the parsing half of the task. It is a parser closely based on the JSON grammar www.json.org/fatfree.html . This exercise shows how the TXR Pattern Language, though geared toward line-oriented, loose matching over entire documents, can nevertheless parse languages. This is implemented with recursive horizontal pattern matching functions, and so basically the definition resembles a grammar. Horizontal functions allow the language to easily specify LL grammars with indefinite lookahead, not restricted to regular languages (thanks to TXR's backtracking). The numerous occurences of @\ in the code are line continuations. Horizontal functions must be written on one logical line. @\ eats the whitespace at the start of the next physical line, to allow indentation. The parser translates to a nested list structure in which the types are labeled with the strings "O", "A", "N", "S" and "K". (Object, array, number, string, and keyword). The largest grammar rule handles JSON string literals. The strategy is to generate a HTML string and then filter from HTML using the :from_html filter in TXR. For instance \uABCD is translated to ꯍ and then the filter will produce the proper Unicode character. Similarly \" is translated to " and \n is translated to etc. A little liberty is taken: the useless commas in JSON are treated as optional. (TXR's built-in JSON Superfluous terminating commas (not generated by the JSON grammar but accepted by some other parsers) are not allowed by this parser.

@(define value (v))@\
  @(cases)@\
    @(string v)@(or)@(num v)@(or)@(object v)@(or)@\
    @(keyword v)@(or)@(array v)@\
  @(end)@\
@(end)
@(define ws)@/[\n\t ]*/@(end)
@(define string (g))@\
  @(local s hex)@\
  @(ws)@\
  "@(coll :gap 0 :vars (s))@\
     @(cases)@\
       \"@(bind s "&quot;")@(or)@\
       \\@(bind s "\\\\")@(or)@\
       \/@(bind s "\\/")@(or)@\
       \b@(bind s "&#8;")@(or)@\
       \f@(bind s "&#12;")@(or)@\
       \n@(bind s "&#10;")@(or)@\
       \r@(bind s "&#13;")@(or)@\
       \t@(bind s "&#9;")@(or)@\
       \u@{hex /[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]/}@\
         @(bind s `&#x@hex;`)@(or)@\
       @{s /[^"\\]*/}@(filter :to_html s)@\
     @(end)@\
     @(until)"@\
   @(end)"@\
  @(ws)@\
  @(cat s "")@\
  @(filter :from_html s)@\
  @(bind g ("S" s))@\
@(end)
@(define num (v))@\
  @(local n)@\
  @(ws)@{n /-?[0-9]+((\.[0-9]+)?([Ee][+\-]?[0-9]+)?)?/}@(ws)@\
  @(bind v ("N" n))@\
@(end)
@(define keyword (v))@\
  @(local k)@\
  @(all)@(ws)@{k /true|false|null/}@(trailer)@/[^A-Za-z0-9_]/@(end)@(ws)@\
  @(bind v ("K" k))@\
@(end)
@(define object (v))@\
  @(local p e pair)@\
  @(ws){@(ws)@(coll :gap 0 :vars (pair))@\
                @(string p):@(value e)@/,?/@\
                @(bind pair (p e))@\
                @(until)}@\
             @(end)}@(ws)@\
  @(bind v ("O" pair))@\
@(end)
@(define array (v))@\
  @(local e)@\
  @(ws)[@(ws)@(coll :gap 0 :var (e))@(value e)@/,?/@(until)]@(end)]@(ws)@\
  @(bind v ("A" e))@\
@(end)
@(freeform)
@(maybe)@(value v)@(end)@badsyntax

A few tests. Note, the badsyntax variable is bound to any trailing portion of the input that does not match the syntax. The call to the parser @(value v) extracts the longest prefix of the input which is consistent with the syntax, leaving the remainder to be matched into badsyntax.

$ echo  -n '{ "a" : { "b" : 3, "c" : [1,2,3] }  }[' | ./txr -l json.txr -
(v "O" ((("S" "a") ("O" ((("S" "b") ("N" "3")) (("S" "c") ("A" (("N" "1") ("N" "2") ("N" "3")))))))))
(badsyntax . "[\n")

$ echo  -n '"\u1234"' | ./txr -l json.txr -
(v "S" "\11064")
(badsyntax . "")

Jump anywhere ↗

Translation of Common Lisp

TXR Lisp has a tagbody similar to Common Lisp. Like the Common Lisp one, it establishes an area of the program with forms labeled by symbols or numbers. The forms can branch to these symbols or numbers using go. When a form initiates a branch, it is gracefully abandoned, which means that unwinding takes place: unwind-protect clean-up forms are called. Once the form is abandoned, control then transfers to the target form. A go transfer may be used to jump out of a lexical closure, if the tagbody is still active. If a closure is captured in a tagbody which then terminates, and that closure is invoked, and tries to use go to jump to adjacent forms in that terminated tagbody, it is an error. An example of this follows, from an interactive session:

1> (let (fun)
      (tagbody
        again
        (set fun (lambda () (go again))))
      [fun])
** expr-1:4: return*: no block named #:tb-dyn-id-0028 is visible
** during evaluation of form (return* #:tb-id-0024
                                      0)
** ... an expansion of (go again)
** which is located at expr-1:4

The above error messages reveal that TXR Lisp's tagbody is implemented by macros, and relies on a dynamic block return. It is provided mainly for compatibility; Common Lisp users using TXR Lisp may find it handy. If the tagbody is still active when the lambda tries to perform a go, it works:

2> (let (fun)
      (tagbody
        (set fun (lambda () (go out)))
        [fun]
        (put-line "this is skipped")
        out
        (put-line "going out")))
going out
nil

The translated Common Lisp example follows:

(tagbody
  beginning
    (put-line "I am in the beginning")
    (usleep 1000000)
    (go end)
  middle
    (put-line "I am in the middle")
    (usleep 1000000)
    (go beginning)
  end
    (put-line "I am in the end")
    (usleep 1000000)
    (go middle))

Output:


I am in the beginning
I am in the end
I am in the middle
I am in the beginning
I am in the end
I am in the middle
I am in the beginning
...

Keyboard input/Obtain a Y or N response ↗

This works not only on Unix-like platforms, but also on Microsoft Windows, because TXR is ported to Windows using a [https://www.kylheku.com/cygnal/index.html modified version of Cygwin].

(with-resources ((tio-orig (tcgetattr) (tcsetattr tio-orig)))
  (let ((tio (copy tio-orig)))
    tio.(go-raw)
    (tcsetattr tio tcsaflush) ;; third arg optional, defaults to tcsadrain
    (whilet ((k (get-char))
             ((not (member k '(#\y #\n #\Y #\N))))))))

The go-raw method on the termios structure only manipulates the structure contents; tcsetattr pushes it down to the TTY driver. go-raw is defined in the TXR standard library like this:

(defmeth termios go-raw (tio)
  tio.(clear-iflags ignbrk brkint parmrk istrip inlcr igncr icrnl ixon)
  tio.(clear-oflags opost)
  tio.(clear-cflags csize parenb)
  tio.(clear-lflags echo echonl icanon isig)
  (if (boundp 'iexten)
    tio.(clear-lflags iexten))
  tio.(set-cflags cs8)
  (set tio.[cc vmin] 1)
  (set tio.[cc vtime] 0))

Least common multiple ↗

$ txr -p '(lcm (expt 2 123) (expt 6 49) 17)'
43259338018880832376582582128138484281161556655442781051813888

Letter frequency ↗

TXR Extraction Language plus TXR Lisp

@(do (defvar h (hash :equal-based)))
@(repeat)
@(coll :vars ())@\
  @{letter /[A-Za-z]/}@(filter :upcase letter)@\
  @(do (inc [h letter 0]))@\
@(end)
@(end)
@(do (dohash (key value h)
       (format t "~a: ~a\n" key value)))

Output:

$ ./txr letterfreq.txr /usr/share/dict/words
A: 64123
B: 15524
C: 31569
[ ... abridged ... ]
X: 2124
Y: 12507
Z: 3238

TXR Lisp

(let* ((s (open-file "/usr/share/dict/words" "r"))
       (chrs [keep-if* chr-isalpha (gun (get-char s))])
       (h [group-reduce (hash) chr-toupper (op succ @1) chrs 0]))
  (dohash (key value h)
    (put-line `@key: @value`)))

Loop over multiple arrays simultaneously ↗

Pattern language

$ txr -c '@(bind a ("a" "b" "c"))
@(bind b ("A" "B" "C"))
@(bind c ("1" "2" "3"))
@(output)
@  (repeat)
@a@b@c
@  (end)
@(end)'
aA1
bB2
cC3

TXR Lisp, using `mapcar`

Here we actually loop over four things: three strings and an infinite list of newlines. The output is built up as one string object that is finally printed in one go.

$ txr -e '(pprint (mappend (op list) "abc" "ABC" "123" 
(repeat "\n")))'
aA1
bB2
cC3

TXR Lisp, using `each`

$ txr -e '(each ((x "abc") (y "ABC") (z "123")) 
(put-line `@x@y@z`))'
aA1
bB2
cC3

Translation of Scheme

;; Scheme's vector-for-each: a one-liner in TXR
;; that happily works over strings and lists.
;; We don't need "srfi-43".
(defun vector-for-each (fun . vecs)
  [apply mapcar fun (range) vecs])

(defun display (obj : (stream *stdout*))
  (pprint obj stream))

(defun newline (: (stream *stdout*))
  (display #\newline stream))

(let ((a (vec "a" "b" "c"))
      (b (vec "A" "B" "C"))
      (c (vec 1 2 3)))
  (vector-for-each
    (lambda (current-index i1 i2 i3)
      (display i1)
      (display i2)
      (display i3)
      (newline))
    a b c))

Translation of Logo

(macro-time
  (defun question-var-to-meta-num (var)
    ^(sys:var ,(int-str (cdr (symbol-name var))))))

(defmacro map (square-fun . square-args)
  (tree-bind [(fun . args)] square-fun
    ^[apply mapcar (op ,fun ,*[mapcar question-var-to-meta-num args])
            (macrolet ([(. args) ^(quote ,args)])
               (list ,*square-args))]))

(defun word (. items)
  [apply format nil "~a~a~a" items])

(defun show (x) (pprinl x))

(show (map [(word ?1 ?2 ?3)] [a b c] [A B C] [1 2 3]))

Output:

(aA1 bB2 cC3)

Loops/With multiple ranges ↗

(defmacro mfor (:form f (var . range-triplets) . forms)
  (with-gensyms (body toval stepval test)
    ^(let (,var)
       (flet ((,body () ,*forms))
         ,*(append-each ((rt (tuples 3 range-triplets)))
             (mac-param-bind f (from to step) rt
               ^((set ,var ,from)
                 (for* ((,toval ,to)
                        (,stepval ,step)
                        (,test (if (<= ,var ,toval)
                                 (fun <=) (fun >=))))
                       ([,test ,var ,toval])
                       ((inc ,var ,stepval))
                   (,body)))))))))

(let ((prod 1) (sum 0)
      (x 5) (y -5) (z -2)
      (one 1) (three 3) (seven 7))
  (mfor (j (- three)    (expt 3 3)         three
           (- seven)    seven              x
           555          (- 550 y)          1
           22           -28                (- three)
           1927         1939               1
           x            y                  z
           (expt 11 x)  (succ (expt 11 x)) 1)
    (upd sum (+ (abs j)))
    (if (and (< (abs prod) (ash 1 27))
             (nzerop j))
      (upd prod (* j))))
  (put-line `sum = @sum; prod = @prod`))

Output:

sum = 348173; prod = -793618560

Luhn test of credit card numbers ↗

@(do (defun luhn (num)
       (for ((i 1) (sum 0))
            ((not (zerop num)) (zerop (mod sum 10)))
            ((inc i) (set num (trunc num 10)))
          (let ((dig (mod num 10)))
            (if (oddp i)
              (inc sum dig)
              (let ((dig2 (* 2 dig)))
                (inc sum (+ (trunc dig2 10) (mod dig2 10)))))))))
@(collect :vars nil)
@{ccnumber /[0-9]+/}
@(output)
@ccnumber -> @(if (luhn (int-str ccnumber 10)) "good" "bad")
@(end)
@(end)

$ txr luhn.txr luhn.txt
49927398716 -> good
49927398717 -> bad
1234567812345678 -> bad
1234567812345670 -> good

Man or boy test ↗

The goal in this solution is to emulate the Algol 60 solution as closely as possible, and not merely get the correct result. For that, we could just crib the Common Lisp or Scheme solution, with more succinct syntax, like this:

(defun A (k x1 x2 x3 x4 x5)
  (labels ((B ()
             (dec k)
             [A k B x1 x2 x3 x4]))
    (if (<= k 0) (+ [x4] [x5]) (B))))

(prinl (A 10 (ret 1) (ret -1) (ret -1) (ret 1) (ret 0)))

To do a proper job, we define a call-by-name system as a set of functions and macros. With these, the function A can be defined as a close transliteration of the Algol, as can the call to A with the integer constants:

(defun-cbn A (k x1 x2 x3 x4 x5)
  (let ((k k))
    (labels-cbn (B ()
                  (dec k)
                  (set B (set A (A k (B) x1 x2 x3 x4))))
      (if (<= k 0)
        (set A (+ x4 x5))
        (B))))) ;; value of (B) correctly discarded here!

(prinl (A 10 1 -1 -1 1 0))

We define the global function with defun-cbn ("cbn" stands for "call by name") and the inner function with labels-cbn. These functions are actually macros which call hidden call-by-value functions. The macros create all the necessary thunks out of their argument expressions, and the hidden functions use local macros to provide transparent access to their arguments from their bodies. Even the fact that a return value is established by an assignment to the function name is simulated. Note that in A and B, we must assign to the variables A and B respectively to establish the return value. This in turn allows the faithful rendition of the detail in the original that the if form discards the value of the call to B. Establishing a return value by assignment, as in Algol, is achieved thanks to the Lisp-2 base of TXR Lisp; we can simultaneously bind a symbol to a function and variable in the same scope. Also, k is treated as a call-by-name argument also, and is explicitly subject to a rebinding inside A, as is apparently the case in the Algol code. This detail is necessary; if we do not rebind k, then it is a by-name reference to the caller's k, which is a by-name reference to its caller's k and so on. Call-by-name is achieved by representing arguments as structure objects that hold get/set lambdas, serving as access thunks, hidden behind macros. These thunks allow two-way access: the passed values can be stored, not only accessed. This creates a problem when the actual arguments are constants or function calls; that is solved. Constants are recognized and re-bound to hidden variables, which are passed in their place. Function calls are passed as thunks configured to reject store attempts with a run-time error. The complete code follows:

(defstruct (cbn-thunk get set) nil get set)

(defmacro make-cbn-val (place)
  (with-gensyms (nv tmp)
    (cond
      ((constantp place)
        ^(let ((,tmp ,place))
           (new cbn-thunk
             get (lambda () ,tmp)
             set (lambda (,nv) (set ,tmp ,nv)))))
      ((bindable place)
        ^(new cbn-thunk
           get (lambda () ,place)
           set (lambda (,nv) (set ,place ,nv))))
      (t
        ^(new cbn-thunk
           get (lambda () ,place)
           set (lambda (ign) (error "cannot set ~s" ',place)))))))

(defun cbn-val (cbs)
  (call cbs.get))

(defun set-cbn-val (cbs nv)
  (call cbs.set nv))

(defplace (cbn-val thunk) body
  (getter setter
    (with-gensyms (thunk-tmp)
      ^(rlet ((,thunk-tmp ,thunk))
         (macrolet ((,getter () ^(cbn-val ,',thunk-tmp))
                    (,setter (val) ^(set-cbn-val ,',thunk-tmp ,val)))
       ,body)))))

(defun make-cbn-fun (sym args . body)
  (let ((gens (mapcar (ret (gensym)) args)))
    ^(,sym ,gens
       (symacrolet ,[mapcar (ret ^(,@1 (cbn-val ,@2))) args gens]
         ,*body))))

(defmacro cbn (fun . args)
  ^(call (fun ,fun) ,*[mapcar (ret ^(make-cbn-val ,@1)) args]))

(defmacro defun-cbn (name (. args) . body)
  (with-gensyms (hidden-fun)
    ^(progn
       (defun ,hidden-fun ())
       (defmacro ,name (. args) ^(cbn ,',hidden-fun ,*args))
       (set (symbol-function ',hidden-fun)
            ,(make-cbn-fun 'lambda args
                           ^(block ,name (let ((,name)) ,*body ,name)))))))

(defmacro labels-cbn ((name (. args) . lbody) . body)
  (with-gensyms (hidden-fun)
    ^(macrolet ((,name (. args) ^(cbn ,',hidden-fun ,*args)))
       (labels (,(make-cbn-fun hidden-fun args
                               ^(block ,name (let ((,name)) ,*lbody ,name))))
         ,*body))))

(defun-cbn A (k x1 x2 x3 x4 x5)
  (let ((k k))
    (labels-cbn (B ()
                  (dec k)
                  (set B (set A (A k (B) x1 x2 x3 x4))))
      (if (<= k 0)
        (set A (+ x4 x5))
        (B))))) ;; value of (B) correctly discarded here!

(prinl (A 10 1 -1 -1 1 0))

Mandelbrot set ↗

Translation of Scheme

Creates same mandelbrot.pgm file.

(defvar x-centre -0.5)
(defvar y-centre 0.0)
(defvar width 4.0)
(defvar i-max 800)
(defvar j-max 600)
(defvar n 100)
(defvar r-max 2.0)
(defvar file "mandelbrot.pgm")
(defvar colour-max 255)
(defvar pixel-size (/ width i-max))
(defvar x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1))))
(defvar y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1))))

;; with-output-to-file macro
(defmacro with-output-to-file (name . body)
  ^(let ((*stdout* (open-file ,name "w")))
     (unwind-protect (progn ,*body) (close-stream *stdout*))))

;; complex number library
(defmacro cplx (x y) ^(cons ,x ,y))
(defmacro re (c) ^(car ,c))
(defmacro im (c) ^(cdr ,c))

(defsymacro c0 '(0 . 0))

(macro-time
  (defun with-cplx-expand (specs body)
    (tree-case specs
       (((re im expr) . rest)
        ^(tree-bind (,re . ,im) ,expr ,(with-cplx-expand rest body)))
       (() (tree-case body
             ((a b . rest) ^(progn ,a ,b ,*rest))
             ((a) a)
             (x (error "with-cplx: invalid body ~s" body))))
       (x (error "with-cplx: bad args ~s" x)))))

(defmacro with-cplx (specs . body)
  (with-cplx-expand specs body))

(defun c+ (x y)
  (with-cplx ((a b x) (c d y))
    (cplx (+ a c) (+ b d))))

(defun c* (x y)
  (with-cplx ((a b x) (c d y))
    (cplx (- (* a c) (* b d)) (+ (* b c) (* a d)))))

(defun modulus (z)
  (with-cplx ((a b z))
    (sqrt (+ (* a a) (* b b)))))

;; Mandelbrot routines
(defun inside-p (z0 : (z c0) (n n))
  (and (< (modulus z) r-max)
       (or (zerop n)
           (inside-p z0 (c+ (c* z z) z0) (- n 1)))))

(defmacro int-bool (b)
  ^(if ,b colour-max 0))

(defun pixel (i j)
  (int-bool
    (inside-p
      (cplx (+ x-offset (* pixel-size i))
            (- y-offset (* pixel-size j))))))

;; Mandelbrot loop and output
(defun plot ()
  (with-output-to-file file
    (format t "P2\n~s\n~s\n~s\n" i-max j-max colour-max)
    (each ((j (range 1 j-max)))
      (each ((i (range 1 i-max)))
        (format *stdout* "~s " (pixel i j)))
      (put-line "" *stdout*))))

(plot)

Maze generation ↗

Simple, Depth-First

Legend: cu = current location; vi = boolean hash of visited locations; pa = hash giving a list neighboring cells to which there is a path from a given cell.

@(bind (width height) (15 15))
@(do
   (defvar *r* (make-random-state nil))
   (defvar vi)
   (defvar pa)

   (defun neigh (loc)
     (let ((x (from loc))
           (y (to loc)))
       (list (- x 1)..y (+ x 1)..y
             x..(- y 1) x..(+ y 1))))

   (defun make-maze-rec (cu)
     (set [vi cu] t)
     (each ((ne (shuffle (neigh cu))))
       (cond ((not [vi ne])
              (push ne [pa cu])
              (push cu [pa ne])
              (make-maze-rec ne)))))

   (defun make-maze (w h)
     (let ((vi (hash :equal-based))
           (pa (hash :equal-based)))
       (each ((x (range -1 w)))
         (set [vi x..-1] t)
         (set [vi x..h] t))
       (each ((y (range* 0 h)))
         (set [vi -1..y] t)
         (set [vi w..y] t))
       (make-maze-rec 0..0)
       pa))

   (defun print-tops (pa w j)
     (each ((i (range* 0 w)))
       (if (memqual i..(- j 1) [pa i..j])
         (put-string "+    ")
         (put-string "+----")))
     (put-line "+"))

   (defun print-sides (pa w j)
     (let ((str ""))
       (each ((i (range* 0 w)))
         (if (memqual (- i 1)..j [pa i..j])
           (set str `@str     `)
           (set str `@str|    `)))
       (put-line `@str|\n@str|`)))

   (defun print-maze (pa w h)
     (each ((j (range* 0 h)))
       (print-tops pa w j)
       (print-sides pa w j))
     (print-tops pa w h)))
@;;
@(bind m @(make-maze width height))
@(do (print-maze m width height))

Output:

+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+
|    |         |                        |                                  |
|    |         |                        |                                  |
+    +    +    +    +    +----+----+    +    +----+----+----+    +    +----+
|    |    |         |         |         |         |         |    |         |
|    |    |         |         |         |         |         |    |         |
+    +----+----+----+----+    +----+----+    +----+    +    +    +----+    +
|                   |         |              |         |    |    |         |
|                   |         |              |         |    |    |         |
+----+----+----+    +    +    +    +----+----+    +----+    +    +    +----+
|              |    |    |    |    |         |    |    |    |    |         |
|              |    |    |    |    |         |    |    |    |    |         |
+    +----+    +    +    +----+    +    +----+    +    +    +    +----+    +
|         |    |    |                   |         |    |    |         |    |
|         |    |    |                   |         |    |    |         |    |
+----+    +    +    +----+----+----+----+    +----+    +    +----+----+    +
|         |    |                   |         |         |              |    |
|         |    |                   |         |         |              |    |
+    +----+    +----+----+----+    +    +----+    +----+----+----+    +    +
|    |                        |         |                        |    |    |
|    |                        |         |                        |    |    |
+----+    +    +----+----+----+----+----+----+----+----+----+    +    +    +
|         |    |                                       |         |         |
|         |    |                                       |         |         |
+    +----+    +    +----+----+    +----+----+----+    +    +    +----+    +
|    |         |    |    |         |              |         |    |         |
|    |         |    |    |         |              |         |    |         |
+    +----+    +    +    +    +----+----+    +    +----+----+    +    +----+
|         |    |         |    |              |              |    |    |    |
|         |    |         |    |              |              |    |    |    |
+    +    +----+    +----+    +    +----+----+----+----+----+    +    +    +
|    |              |         |         |                   |    |         |
|    |              |         |         |                   |    |         |
+    +----+----+----+    +----+----+    +    +----+----+    +    +----+    +
|              |    |    |              |    |         |         |         |
|              |    |    |              |    |         |         |         |
+----+----+    +    +    +----+    +----+    +    +    +----+----+    +----+
|    |              |         |                   |              |    |    |
|    |              |         |                   |              |    |    |
+    +    +----+----+----+    +    +----+----+----+----+----+    +    +    +
|         |                   |              |              |    |         |
|         |                   |              |              |    |         |
+    +----+    +----+----+----+----+----+----+    +----+    +----+----+    +
|         |                                            |                   |
|         |                                            |                   |
+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+

Quality Breadth-First

The following is a complete, self-contained command line utility. We also drop use of the TXR pattern extraction language and work purely in TXR Lisp. The algorithm is quite different from the previous. This version is not recursive. This algorithm divides the maze cells into visited cells, frontier cells and unvisited cells. As in the DFS version, border cells outside of the maze area are pre-initialized as visited, for convenience. The frontier set initially contains the upper left hand corner. The algorithm's main loop iterates while there are frontier cells. As the generation progresses, unvisited cells adjacent to frontier cells added to the frontier set. Frontier cells that are only surrounded by other frontier cells or visited cells are removed from the frontier set and become visited cells. Eventually, all unvisited cells become frontier cells and then visited cells, at which point the frontier set becomes empty and the algorithm terminates. At every step, the algorithm picks the first cell in the frontier list. In the code, the frontier cells are kept in a hash called fr and also in a queue q. The algorithm tries to extend the frontier around the frontier cell which is at the head of the queue q by randomly choosing an adjacent unvisited cell. (If there is no such cell, the node is not a frontier node any more and is popped from the queue and fr set). If an unvisited node is picked, then a two-way path is broken from the given frontier cell to that cell, and that cell is added to the frontier set. Important: the new frontier cell is added to the head of the queue, rather than the tail. The algorithm is modified by a "straightness" parameter, which is used to initialize a counter. Every time a new frontier node is added to the front of the queue, the counter decrements. When it reaches zero, the frontier queue is scrambled, and the counter is reset. As long as the count is nonzero, the maze growth proceeds from the previously traversed node, because the new node is placed at the head of the queue. This behavior mimics the DFS algorithm, resulting in long corridors without a lot of branching. At the user interface level, the straightness parameter is represented as a percentage. This percentage is converted to a number of cells based on the width and height of the maze. For instance if the straightness parameter is 15, and the maze size is 20x20, it means that 15% out of 400 cells, or 60 cells will be traversed before the queue is scrambled. Then another 60 will be traversed and the queue will be scrambled, and so forth.

(defvar vi)  ;; visited hash
(defvar pa)  ;; path connectivity hash
(defvar sc)  ;; count, derived from straightness fator

(defun rnd-pick (list)
  (if list [list (rand (length list))]))

(defun neigh (loc)
  (let ((x (from loc))
        (y (to loc)))
    (list (- x 1)..y (+ x 1)..y
          x..(- y 1) x..(+ y 1))))

(defun make-maze-impl (cu)
  (let ((q (list cu))
        (c sc))
    (set [vi cu] t)
    (while q
      (let* ((cu (first q))
             (ne (rnd-pick (remove-if vi (neigh cu)))))
        (cond (ne (set [vi ne] t)
                  (push ne [pa cu])
                  (push cu [pa ne])
                  (push ne q)
                  (cond ((<= (dec c) 0)
                         (set q (shuffle q))
                         (set c sc))))
              (t (pop q)))))))

(defun make-maze (w h sf)
  (let ((vi (hash :equal-based))
        (pa (hash :equal-based))
        (sc (max 1 (trunc (* sf w h) 100))))
    (each ((x (range -1 w)))
      (set [vi x..-1] t)
      (set [vi x..h] t))
    (each ((y (range* 0 h)))
      (set [vi -1..y] t)
      (set [vi w..y] t))
    (make-maze-impl 0..0)
    pa))

(defun print-tops (pa w j)
  (each ((i (range* 0 w)))
    (if (memqual i..(- j 1) [pa i..j])
      (put-string "+    ")
      (put-string "+----")))
  (put-line "+"))

(defun print-sides (pa w j)
  (let ((str ""))
    (each ((i (range* 0 w)))
      (if (memqual (- i 1)..j [pa i..j])
        (set str `@str     `)
        (set str `@str|    `)))
    (put-line `@str|\n@str|`)))

(defun print-maze (pa w h)
  (each ((j (range* 0 h)))
    (print-tops pa w j)
    (print-sides pa w j))
  (print-tops pa w h))

(defun usage ()
  (let ((invocation (ldiff *full-args* *args*)))
    (put-line "usage: ")
    (put-line `@invocation <width> <height> [<straightness>]`)
    (put-line "straightness-factor is a percentage, defaulting to 15")
    (exit 1)))

(let ((args [mapcar int-str *args*])
      (*random-state* (make-random-state nil)))
  (if (memq nil args)
    (usage))
  (tree-case args
    ((w h s ju . nk) (usage))
    ((w h : (s 15)) (set w (max 1 w))
                    (set h (max 1 h))
                    (print-maze (make-maze w h s) w h))
    (else (usage))))

Output:

Three mazes are generated, at the lowest, intermediate and highest "straightness factors". It is immediately obvious that the style of each maze is quite different.


# 10x10 maze with zero percent "straightness factor"
$ txr maze-generation3.txr 10 10 0
+----+----+----+----+----+----+----+----+----+----+
|                   |    |                        |
|                   |    |                        |
+    +    +----+----+    +    +    +----+----+----+
|    |         |              |         |         |
|    |         |              |         |         |
+    +    +----+    +----+----+----+----+    +    +
|    |    |                   |              |    |
|    |    |                   |              |    |
+    +----+    +----+    +----+    +----+----+----+
|                   |                             |
|                   |                             |
+----+    +    +    +    +    +    +----+----+----+
|         |    |    |    |    |                   |
|         |    |    |    |    |                   |
+----+    +    +----+----+    +----+----+----+    +
|         |              |                   |    |
|         |              |                   |    |
+    +----+    +----+----+    +    +    +----+    +
|    |                   |    |    |         |    |
|    |                   |    |    |         |    |
+    +----+    +    +    +    +    +    +    +    +
|    |         |    |    |    |    |    |    |    |
|    |         |    |    |    |    |    |    |    |
+----+    +    +----+    +    +    +----+----+    +
|         |         |    |    |         |         |
|         |         |    |    |         |         |
+    +    +    +    +----+----+----+----+----+    +
|    |    |    |                        |         |
|    |    |    |                        |         |
+----+----+----+----+----+----+----+----+----+----+


# with 10% straightnes factor
$ txr maze-generation3.txr 10 10 10
+----+----+----+----+----+----+----+----+----+----+
|    |              |         |         |         |
|    |              |         |         |         |
+    +    +----+    +    +    +    +    +----+    +
|              |         |         |              |
|              |         |         |              |
+    +----+----+    +----+----+----+----+----+----+
|    |         |         |                        |
|    |         |         |                        |
+----+    +    +----+    +    +----+----+    +    +
|         |              |         |    |    |    |
|         |              |         |    |    |    |
+    +----+----+    +----+    +    +    +    +----+
|    |                   |    |         |    |    |
|    |                   |    |         |    |    |
+    +    +----+----+----+----+----+----+    +    +
|    |                   |                        |
|    |                   |                        |
+    +    +----+    +    +    +    +----+----+----+
|    |    |         |    |    |    |         |    |
|    |    |         |    |    |    |         |    |
+    +----+    +----+    +----+    +    +    +    +
|    |         |                   |    |         |
|    |         |                   |    |         |
+    +    +----+----+    +----+    +    +----+----+
|    |         |         |         |         |    |
|    |         |         |         |         |    |
+----+----+    +----+    +    +----+----+    +    +
|                   |    |                        |
|                   |    |                        |
+----+----+----+----+----+----+----+----+----+----+

# with 100 percent straight factor
$ txr maze-generation3.txr 10 10 100
+----+----+----+----+----+----+----+----+----+----+
|         |                             |         |
|         |                             |         |
+----+    +----+    +----+----+    +    +    +    +
|    |         |              |    |    |    |    |
|    |         |              |    |    |    |    |
+    +----+    +----+----+----+    +    +    +    +
|         |    |         |         |    |    |    |
|         |    |         |         |    |    |    |
+    +----+    +    +    +    +----+    +----+    +
|    |         |    |    |         |              |
|    |         |    |    |         |              |
+    +    +----+    +    +    +    +----+----+    +
|    |    |         |    |    |         |         |
|    |    |         |    |    |         |         |
+    +    +----+    +    +----+    +    +----+----+
|    |              |         |    |              |
|    |              |         |    |              |
+    +----+----+----+----+    +----+----+----+    +
|              |         |              |         |
|              |         |              |         |
+    +----+----+    +    +----+----+    +    +    +
|         |         |         |    |         |    |
|         |         |         |    |         |    |
+    +    +    +----+    +    +    +----+----+    +
|    |         |         |                   |    |
|    |         |         |                   |    |
+    +----+----+    +----+----+----+----+----+    +
|              |                                  |
|              |                                  |
+----+----+----+----+----+----+----+----+----+----+

Metaprogramming ↗

TXR has a built-in Lisp dialect called TXR Lisp, which supports meta-programming, some of which is patterned after ANSI Common Lisp. TXR provides:

run-time access to its parser for Lisp expressions: (read "(+ a b c)");
a parser for regular exprssions: (regex-parse "a.*b") which produces abstract syntax;
a run-time compiler for converting regular expression abstract syntax to compiled regular expression object;
a eval function which expands and evaluates Lisp abstract syntax;
global as well as lexically scoped macros, for both compound forms (with automatically destructured parameter lists) and symbols (symbol macros): the operators defmacro, defsymacro, macrolet and symacrolet;
structural quasiquote for convenient macro writing.

Example define a while loop which supports break and continue. Two forms of break are supported break which causes the loop to terminate with the return value nil and (break <form>) which returns the specified value.

(defmacro whil ((condition : result) . body)
  (let ((cblk (gensym "cnt-blk-"))
        (bblk (gensym "brk-blk-")))
    ^(macrolet ((break (value) ^(return-from ,',bblk ,value)))
       (symacrolet ((break (return-from ,bblk))
                    (continue (return-from ,cblk)))
         (block ,bblk
           (for () (,condition ,result) ()
             (block ,cblk ,*body)))))))

(let ((i 0))
  (whil ((< i 100))
    (if (< (inc i) 20)
      continue)
    (if (> i 30)
      break)
    (prinl i)))

(prinl
  (sys:expand
    '(whil ((< i 100))
       (if (< (inc i) 20)
         continue)
       (if (> i 30)
         break)
       (prinl i))))

Output:

20
21
22
23
24
25
26
27
28
29
30
(block #:brk-blk-0062
  (for () ((< i 100) ())
    () (block #:cnt-blk-0061
         (if (< (sys:setq i (succ i))
                20) (return-from
                      #:cnt-blk-0061))
         (if (> i 30)
           (return-from
             #:brk-blk-0062))
         (prinl i))))

Modular exponentiation ↗

From your system prompt:

$ txr -p '(exptmod 2988348162058574136915891421498819466320163312926952423791023078876139
                   2351399303373464486466122544523690094744975233415544072992656881240319
                   (expt 10 40)))'
1527229998585248450016808958343740453059

Multiline shebang ↗

#!/bin/sh
sed -n -e '4,$p' < "$0" | /usr/bin/txr -B - "$0" "$@"
exit $?
@(next :args)
@(collect)
@arg
@(end)

Test run:

$ ./multilineshebang.txr
arg[0]="./multilineshebang.txr"
$ ./multilineshebang.txr 1
arg[0]="./multilineshebang.txr"
arg[1]="1"
$ ./multilineshebang.txr 1 2 3
arg[0]="./multilineshebang.txr"
arg[1]="1"
arg[2]="2"
arg[3]="3"
$

Multisplit ↗

Using text-extraction pattern language

Here, the separators are embedded into the syntax rather than appearing as a datum. Nevertheless, this illustrates how to do that small tokenizing task with various separators. The clauses of choose are applied in parallel, and all potentially match at the current position in the text. However :shortest tok means that only that clause survives (gets to propagate its bindings and position advancement) which minimizes the length of the string which is bound to the tok variable. The :gap 0 makes the horizontal collect repetitions strictly adjacent. This means that coll will quit when faced with a nonmatching suffix portion of the data rather than scan forward (no gap allowed!). This creates an opportunity for the tail variable to grab the suffix which remains, which may be an empty string.

@(next :args)
@(coll :gap 0)@(choose :shortest tok)@\
                @tok@{sep /==/}@\
              @(or)@\
                @tok@{sep /!=/}@\
              @(or)@\
                @tok@{sep /=/}@\
              @(end)@(end)@tail
@(output)
@(rep)"@tok" {@sep} @(end)"@tail"
@(end)

Runs:

$ ./txr multisplit.txr 'a!===b=!=c'
"a" {!=} "" {==} "b" {=} "" {!=} "c"
$ ./txr  multisplit.txr 'a!===!==!=!==b'
"a" {!=} "" {==} "" {!=} "" {=} "" {!=} "" {!=} "" {=} "b"
$ ./txr  multisplit.txr ''
""
$ ./txr  multisplit.txr 'a'
"a"
$ ./txr  multisplit.txr 'a='
"a" {=} ""
$ ./txr  multisplit.txr '='
"" {=} ""
$ ./txr  multisplit.txr '=='
"" {==} ""
$ ./txr  multisplit.txr '==='
"" {==} "" {=} ""

Using the `tok-str` function

Translation of Racket

$ txr -p '(tok-str "a!===b=!=c" #/==|!=|=/ t)'
("a" "!=" "" "==" "b" "=" "" "!=" "c")

Here the third boolean argument means "keep the material between the tokens", which in the Racket version seems to be requested by the argument #:gap-select? #:t.

Mutual recursion ↗

(defun f (n)
  (if (>= 0 n)
    1
    (- n (m (f (- n 1))))))

(defun m (n)
  (if (>= 0 n)
    0
    (- n (f (m (- n 1))))))

(each ((n (range 0 15)))
  (format t "f(~s) = ~s; m(~s) = ~s\n" n (f n) n (m n)))

$ txr mutual-recursion.txr
f(0) = 1; m(0) = 0
f(1) = 1; m(1) = 0
f(2) = 2; m(2) = 1
f(3) = 2; m(3) = 2
f(4) = 3; m(4) = 2
f(5) = 3; m(5) = 3
f(6) = 4; m(6) = 4
f(7) = 5; m(7) = 4
f(8) = 5; m(8) = 5
f(9) = 6; m(9) = 6
f(10) = 6; m(10) = 6
f(11) = 7; m(11) = 7
f(12) = 8; m(12) = 7
f(13) = 8; m(13) = 8
f(14) = 9; m(14) = 9
f(15) = 9; m(15) = 9

Narcissist ↗

@(bind my64 "QChuZXh0IDphcmdzKUBmaWxlbmFtZUAobmV4dCBmaWxlbmFtZSlAZmlyc3RsaW5lQChmcmVlZm9ybSAiIilAcmVzdEAoYmluZCBpbjY0IEAoYmFzZTY0LWVuY29kZSByZXN0KSlAKGNhc2VzKUAgIChiaW5kIGZpcnN0bGluZSBgXEAoYmluZCBteTY0ICJAbXk2NCIpYClAICAoYmluZCBpbjY0IG15NjQpQCAgKGJpbmQgcmVzdWx0ICIxIilAKG9yKUAgIChiaW5kIHJlc3VsdCAiMCIpQChlbmQpQChvdXRwdXQpQHJlc3VsdEAoZW5kKQ==")
@(next :args)
@filename
@(next filename)
@firstline
@(freeform "")
@rest
@(bind in64 @(base64-encode rest))
@(cases)
@  (bind firstline `\@(bind my64 "@my64")`)
@  (bind in64 my64)
@  (bind result "1")
@(or)
@  (bind result "0")
@(end)
@(output)
@result
@(end)

Output:

$ txr narcissist.txr narcissist.txr
1

Null object ↗

Object serialization ↗

TXR Lisp has good support for object serialization. The object file format for compiled files (.tlo files) depends on it.

(defstruct shape ()
  (pos-x 0.0) (pos-y 0.0))

(defstruct circle (shape)
  radius)

(defstruct ellipse (shape)
  min-radius maj-radius)

(defvarl shapes (list (new circle radius 3.0)
                      (new ellipse min-radius 4.0 maj-radius 5.0)))

(put-line "original shapes:")
(prinl shapes)

(file-put "shapes.tl" shapes)

(put-line "dump of shapes.tl file:")
(put-line (file-get-string "shapes.tl"))

(put-line "object list read from file:")
(prinl (file-get "shapes.tl"))

Output:

original shapes:
(#S(circle pos-x 0.0 pos-y 0.0 radius 3.0) #S(ellipse pos-x 0.0 pos-y 0.0 min-radius 4.0 maj-radius 5.0))
dump of shapes.tl file:
(#S(circle pos-x 0.0 pos-y 0.0 radius 3.0) #S(ellipse pos-x 0.0 pos-y 0.0 min-radius 4.0 maj-radius 5.0))

object list read from file:
(#S(circle pos-x 0.0 pos-y 0.0 radius 3.0) #S(ellipse pos-x 0.0 pos-y 0.0 min-radius 4.0 maj-radius 5.0))

An object can be given a print method which has a Boolean argument whether to print "pretty" (meaning in some nicely formatted form for humans, not necessarily a serial notation readable by machine). A print method can return the : (colon) symbol to indicate that it declines to print; the default implementation should be used. With that it it possible to do

(defstruct shape ()
  (pos-x 0.0) (pos-y 0.0))

(defstruct circle (shape)
  radius
  (:method print (me stream pretty-p)
    (if pretty-p
      (put-string `#<circle of radius @{me.radius} at coordinates (@{me.pos-x}, @{me.pos-y})>`)
      :)))

(let ((circ (new circle radius 5.3)))
  (prinl circ)    ;; print machine readably
  (pprinl circ))  ;; print pretty

Output:

#S(circle pos-x 0.0 pos-y 0.0 radius 5.3)
#<circle of radius 5.3 at coordinates (0, 0)>

Old lady swallowed a fly ↗

Here is somewhat verbose program showing a different approach. The idea is to start with the last two verses of the song, and then work backwards to produce the earlier verses. This is done by recursively pattern matching on the song to extract text and produce the earlier verse, which is then prepended to the song. The later verse does not contain one key piece of information we need to produce the prior verse: the animal-specific answer line for the prior animal. So we look this up by scanning a text which serves as a table. The recursion terminates when the second pattern case matches the first verse: the third line is "Perhaps she'll die". In this case the song is not lengthened any more, and a terminating flag variable is bound to true. Note one detail: in the first verse we have "... don't know why she swallowed the fly". But in subsequent verses it is "that fly" not "the fly". So we do a lookup on the fly also to substitute the appropriate line, and in the fly case we skip the original line (see the first @(maybe)).

@(deffilter abbr
   ("IK" "I know an old lady who swallowed a") ("SW" "She swallowed the")
   ("SS" "she swallowed") ("CA" "to catch the") ("XX" "Perhaps she'll die")
   ("C" "cow") ("G" "goat") ("D" "dog") ("@" "cat") ("R" "bird")
   ("$" "spider") ("F" "fly"))
@(bind lastverse
   ("IK C"
    "I don't know how SS the C"
    "SW C CA G"
    "SW G CA D"
    "SW D CA @"
    "SW @ CA R"
    "SW R CA $"
    "SW $ CA F"
    "But I don't know why SS that F"
    "XX"
    ""
    "IK horse"
    "She's alive and well of course!"))
@(bind animal_line
  ("G: Opened her throat and down went the G!"
   "D: What a hog to swallow a D!"
   "@: Imagine that! She swallowed a @!"
   "R: How absurd to swallow a R!"
   "$: That wriggled and jiggled and tickled inside her"
   "F: But I don't know why SS the F"))
@(define expand_backwards (song lengthened_song done))
@  (local line2 line3 verse rest animal previous_animal previous_animal_verse)
@  (next :list song)
@  (cases)
IK @animal
@line2
SW @animal CA @previous_animal
@    (maybe)
But @(skip)F
@    (end)
@    (collect)
@    verse
@    (until)

@    (end)
@    (collect)
@    rest
@    (end)
@    (next :list animal_line)
@    (skip)
@previous_animal: @previous_animal_verse
@    (output :into lengthened_song)
IK @previous_animal
@previous_animal_verse
@      (repeat)
@      verse
@      (end)

@      (repeat)
@      song
@      (end)
@    (end)
@    (bind done nil)
@ (or)
IK @(skip)
@line2
XX
@    (bind lengthened_song song)
@    (bind done t)
@ (end)
@(end)
@(define expand_song (in out))
@  (local lengthened done)
@  (expand_backwards in lengthened done)
@  (cases)
@    (bind done nil)
@    (expand_song lengthened out)
@  (or)
@    (bind out lengthened)
@  (end)
@(end)
@(expand_song lastverse song)
@(output :filter abbr)
@  (repeat)
@song
@  (end)
@(end)

Pangram checker ↗

@/.*[Aa].*&.*[Bb].*&.*[Cc].*&.*[Dd].*& \
  .*[Ee].*&.*[Ff].*&.*[Gg].*&.*[Hh].*& \
  .*[Ii].*&.*[Jj].*&.*[Kk].*&.*[Ll].*& \
  .*[Mm].*&.*[Nn].*&.*[Oo].*&.*[Pp].*& \
  .*[Qq].*&.*[Rr].*&.*[Ss].*&.*[Tt].*& \
  .*[Uu].*&.*[Vv].*&.*[Ww].*&.*[Xx].*& \
  .*[Yy].*&.*[Zz].*/

Run:

$ echo "The quick brown fox jumped over the lazy dog." | txr is-pangram.txr -
$echo $? # failed termination
1
$ echo "The quick brown fox jumped over the lazy dogs." | txr is-pangram.txr -
$ echo $?   # successful termination
0

Parsing/RPN to infix conversion ↗

This solution is a little long because it works by translating RPN to fully parenthesized prefix (Lisp notation). Also, it improves upon the problem slightly. Note that for the operators * and +, the associativity is configured asnil ("no associativity") rather than left-to-right. This is because these operators obey the associative property: (a + b) + c is a + (b + c), and so we usually write a + b + c or a * b * c without any parentheses, leaving it ambiguous which addition is done first. Associativity is not important for these operators. The lisp-to-infix filter then takes advantage of this non-associativity in minimizing the parentheses.

;; alias for circumflex, which is reserved syntax
(defvar exp (intern "^"))

(defvar *prec* ^((,exp . 4) (* . 3) (/ . 3) (+ . 2) (- . 2)))

(defvar *asso* ^((,exp . :right) (* . nil)
                 (/ . :left) (+ . nil) (- . :left)))

(defun debug-print (label val)
  (format t "~a: ~a\n" label val)
  val)

(defun rpn-to-lisp (rpn)
  (let (stack)
    (each ((term rpn))
      (if (symbolp (debug-print "rpn term" term))
        (let ((right (pop stack))
              (left (pop stack)))
          (push ^(,term ,left ,right) stack))
        (push term stack))
      (debug-print "stack" stack))
    (if (rest stack)
      (return-from error "*excess stack elements*"))
      (debug-print "lisp" (pop stack))))

(defun prec (term)
  (or (cdr (assoc term *prec*)) 99))

(defun asso (term dfl)
  (or (cdr (assoc term *asso*)) dfl))

(defun inf-term (op term left-or-right)
  (if (atom term)
    `@term`
    (let ((pt (prec (car term)))
          (po (prec op))
          (at (asso (car term) left-or-right))
          (ao (asso op left-or-right)))
      (cond
        ((< pt po) `(@(lisp-to-infix term))`)
        ((> pt po) `@(lisp-to-infix term)`)
        ((and (eq at ao) (eq left-or-right ao)) `@(lisp-to-infix term)`)
        (t `(@(lisp-to-infix term))`)))))

(defun lisp-to-infix (lisp)
  (tree-case lisp
    ((op left right) (let ((left-inf (inf-term op left :left))
                           (right-inf (inf-term op right :right)))
                       `@{left-inf} @op @{right-inf}`))
    (()              (return-from error "*stack underflow*"))
    (else            `@lisp`)))

(defun string-to-rpn (str)
  (debug-print "rpn"
    (mapcar (do if (int-str @1) (int-str @1) (intern @1))
            (tok-str str #/[^ \t]+/))))

(debug-print "infix"
  (block error
     (tree-case *args*
       ((a b . c) "*excess args*")
       ((a) (lisp-to-infix (rpn-to-lisp (string-to-rpn a))))
       (else "*arg needed*"))))

Output:

$ txr rpn.tl '3 4 2 * 1 5 - 2 3 ^ ^ / +'
rpn: (3 4 2 * 1 5 - 2 3 ^ ^ / +)
rpn term: 3
stack: (3)
rpn term: 4
stack: (4 3)
rpn term: 2
stack: (2 4 3)
rpn term: *
stack: ((* 4 2) 3)
rpn term: 1
stack: (1 (* 4 2) 3)
rpn term: 5
stack: (5 1 (* 4 2) 3)
rpn term: -
stack: ((- 1 5) (* 4 2) 3)
rpn term: 2
stack: (2 (- 1 5) (* 4 2) 3)
rpn term: 3
stack: (3 2 (- 1 5) (* 4 2) 3)
rpn term: ^
stack: ((^ 2 3) (- 1 5) (* 4 2) 3)
rpn term: ^
stack: ((^ (- 1 5) (^ 2 3)) (* 4 2) 3)
rpn term: /
stack: ((/ (* 4 2) (^ (- 1 5) (^ 2 3))) 3)
rpn term: +
stack: ((+ 3 (/ (* 4 2) (^ (- 1 5) (^ 2 3)))))
lisp: (+ 3 (/ (* 4 2) (^ (- 1 5) (^ 2 3))))
infix: 3 + 4 * 2 / (1 - 5) ^ 2 ^ 3

$ txr rpn.tl '1 2 + 3 4 + ^ 5 6 + ^'
rpn: (1 2 + 3 4 + ^ 5 6 + ^)
rpn term: 1
stack: (1)
rpn term: 2
stack: (2 1)
rpn term: +
stack: ((+ 1 2))
rpn term: 3
stack: (3 (+ 1 2))
rpn term: 4
stack: (4 3 (+ 1 2))
rpn term: +
stack: ((+ 3 4) (+ 1 2))
rpn term: ^
stack: ((^ (+ 1 2) (+ 3 4)))
rpn term: 5
stack: (5 (^ (+ 1 2) (+ 3 4)))
rpn term: 6
stack: (6 5 (^ (+ 1 2) (+ 3 4)))
rpn term: +
stack: ((+ 5 6) (^ (+ 1 2) (+ 3 4)))
rpn term: ^
stack: ((^ (^ (+ 1 2) (+ 3 4)) (+ 5 6)))
lisp: (^ (^ (+ 1 2) (+ 3 4)) (+ 5 6))
infix: ((1 + 2) ^ (3 + 4)) ^ (5 + 6)

Associativity tests (abbreviated output):

$ txr rpn.tl '1 2 3 + +'
[ ... ]
infix: 1 + 2 + 3

$ txr rpn.tl '1 2 + 3 +'
[ ... ]
infix: 1 + 2 + 3

$ txr rpn.tl '1 2 3 ^ ^'
rpn tokens: [1 2 3 ^ ^]
[ ... ]
infix: 1 ^ 2 ^ 3

$ txr rpn.tl '1 2 ^ 3 ^'
[ ... ]
infix: (1 ^ 2) ^ 3

$ txr rpn.tl '1 1 - 3 +'
[ .. ]
infix: 1 - 1 + 3

$ txr rpn.tl '3 1 1 - +'
[ .. ]
infix: 3 + (1 - 1)

Partial function application ↗

Partial application is built in via the op operator, so there is no need to create all these named functions, which defeats the purpose and beauty of partial application: which is to partially apply arguments to functions in an anonymous, implicit way, possibly in multiple places in a single expression. Indeed, functional language purists would probably say that even the explicit op operator spoils it, somewhat.

$ txr -p "(mapcar (op mapcar (op * 2)) (list (range 0 3) (range 2 8 2)))"
((0 2 4 6) (4 8 12 16))

$ txr -p "(mapcar (op mapcar (op * @1 @1)) (list (range 0 3) (range 2 8 2)))"
((0 1 4 9) (4 16 36 64))

Note how in the above, no function arguments are explicitly mentioned at all except the necessary reference @1 to an argument whose existence is implicit. Now, without further ado, we surrender the concept of partial application to meet the task requirements:

$ txr -e "(progn
  (defun fs (fun seq) (mapcar fun seq))
  (defun f1 (num) (* 2 num))
  (defun f2 (num) (* num num))
  (defvar fsf1 (op fs f1))  ;; pointless: can just be (defun fsf1 (seq) (fs f1 seq)) !!!
  (defvar fsf2 (op fs f2)) 

  (print [fs fsf1 '((0 1 2 3) (2 4 6 8))]) (put-line \"\")
  (print [fs fsf2 '((0 1 2 3) (2 4 6 8))]) (put-line \"\"))"
((0 2 4 6) (4 8 12 16))
((0 1 4 9) (4 16 36 64))

Pick random element ↗

Translation of Tcl

@(do (defun randelem (seq)
       [seq (random nil (length seq))]))
@(bind x @(randelem #("a" "b" "c" "d")))

Polymorphic copy ↗

TXR Lisp has a copy function that produces copies of objects of all sorts. Structures are shallowly copied; the copy-struct function is used when the argument is a structure. Our polymorphic object can use copy to make a shallow copy of itself which shares a reference to the contained object. Then break the reference by calling copy on the object contained in the copy.

(defstruct base ()
  (:method identify (self) (put-line "base")))

(defstruct derived (base)
  (:method identify (self) (put-line "derived")))

(defstruct poly ()
  obj

  (:method deep-copy (self)
    (let ((c (copy self))) ;; make copy of s
      (upd c.obj copy)     ;; copy self's obj
      c)))                 ;; return c

;; Test

(let* ((b (new base))
       (d (new derived))
       (p (new poly obj d)))
  b.(identify) ;; prints base
  d.(identify) ;; prints derived

  (let ((c p.(deep-copy)))
    p.obj.(identify) ;; prints derived
    (prinl (eq p.obj c.obj)))) ;; prints nil: c.obj is not a ref to p.obj

Output:

base
derived
derived
nil

Power set ↗

The power set function can be written concisely like this:

(defun power-set (s)
  (mappend* (op comb s) (range 0 (length s))))

This generates the lists of combinations of all possible lengths, from 0 to the length of s and catenates them. The comb function generates a lazy list, so it is appropriate to use mappend* (the lazy version of mappend) to keep the behavior lazy. A complete program which takes command line arguments and prints the power set in comma-separated brace notation:

@(do (defun power-set (s)
       (mappend* (op comb s) (range 0 (length s)))))
@(bind pset @(power-set *args*))
@(output)
@  (repeat)
{@(rep)@pset, @(last)@pset@(empty)@(end)}
@  (end)
@(end)

Output:

$ txr rosetta/power-set.txr  1 2 3
{1, 2, 3}
{1, 2}
{1, 3}
{1}
{2, 3}
{2}
{3}
{}

The above power-set function generalizes to strings and vectors.

@(do (defun power-set (s)
       (mappend* (op comb s) (range 0 (length s))))
     (prinl (power-set "abc"))
     (prinl (power-set "b"))
     (prinl (power-set ""))
     (prinl (power-set #(1 2 3))))

Output:

$ txr power-set-generic.txr
("" "a" "b" "c" "ab" "ac" "bc" "abc")
("" "b")
("")
(#() #(1) #(2) #(3) #(1 2) #(1 3) #(2 3) #(1 2 3))

Prime decomposition ↗

Translation of Common Lisp

@(next :args)
@(do
  (defun factor (n)
    (if (> n 1)
      (for ((max-d (isqrt n))
            (d 2))
           ()
           ((inc d (if (evenp d) 1 2)))
        (cond ((> d max-d) (return (list n)))
              ((zerop (mod n d))
               (return (cons d (factor (trunc n d))))))))))
@{num /[0-9]+/}
@(bind factors @(factor (int-str num 10)))
@(output)
@num -> {@(rep)@factors, @(last)@factors@(end)}
@(end)

Output:

$ txr factor.txr 1139423842450982345
1139423842450982345 -> {5, 19, 37, 12782467, 25359769}
$ txr factor.txr 1
1 -> {}
$ txr factor.txr 2
2 -> {2}
$ txr factor.txr 3
3 -> {3}
$ txr factor.txr 2
2 -> {2}
$ txr factor.txr 3
3 -> {3}
$ txr factor.txr 4
4 -> {2, 2}
$ txr factor.txr 5
5 -> {5}
$ txr factor.txr 6
6 -> {2, 3}

Program name ↗

Given this code in program-name.txr, marked executable:

#!/usr/local/bin/txr -B
@(bind my-name @self-path)

If we run it as an executable:

$ ./program-name.txr
my-name="./program-name.txr"

If we pass it as an argument to txr:

$ txr program-name.txr
my-name="program-name.txr"

If we evaluate the same thing on the command line:

$ txr -c '@(bind my-name @self-path)'
my-name="cmdline"

If we pass in the code on standard input:

$ txr -
@(bind my-name @self-path)
my-name="stdin"

Quine ↗

A suite for four variations on a theme. The first three use HTML encoding to avoid solving quoting problem. The third stops using 
 to encode newlines, but instead represents the coded portion of the program as a list of lines rather than a string containing newlines encoded in some other way. The fourth dispenses with the HTML crutch and solves the quoting problem with a filter defined in the program itself.

"double filtered"

@(deffilter me ("ME" "@(bind me &quot;ME&quot;)&#10;@(output)&#10;@@(deffilter me (&quot;ME&quot; &quot;@{me :filter me}&quot;))&#10;@{me :filter (me :from_html)}&#10;@(end)"))
@(bind me "ME")
@(output)
@@(deffilter me ("ME" "@{me :filter me}"))
@{me :filter (me :from_html)}
@(end)

"straight up"

@(bind me "@(output)&#10;@@(bind me &quot;@me&quot;)&#10;@{me :filter :from_html}&#10;@(end)")
@(output)
@@(bind me "@me")
@{me :filter :from_html}
@(end)

"code free"

@(bind me ("@(output)" "@@(bind me (@(rep)&quot;@me&quot; @(last)&quot;@me&quot;@(end)))" "@(repeat)" "@{me :filter :from_html}" "@(end)" "@(end)"))
@(output)
@@(bind me (@(rep)"@me" @(last)"@me"@(end)))
@(repeat)
@{me :filter :from_html}
@(end)
@(end)

"404"

@(bind me ("@(deffilter q (*'**'*' *'*/*'*') (*'**/*' *'*/*/*') (*'*****' *'***'))" "@(output)" "@@(bind me (@(rep)*'@me*' @(last)*'@me*'@(end)))" "@(repeat)" "@{me :filter q}" "@(end)" "@(end)"))
@(deffilter q ("*'" "\"") ("*/" "\\") ("**" "*"))
@(output)
@@(bind me (@(rep)"@me" @(last)"@me"@(end)))
@(repeat)
@{me :filter q}
@(end)
@(end)

Random number generator (included)↗

TXR 50 has a PRNG API, and uses a re-implementation of WELL 512 (avoiding contagion by the "contact authors for commercial uses" virus present in the reference implementation, which attacks BSD licenses). Mersenne Twister was a runner up. There is an object of type random-state, and a global variable *random-state* which holds the default random state. Programs can create random states which are snapshots of existing ones, or which are seeded using an integer value (which can be a bignum). The random function produces a random number modulo some integer value, which can have arbitrary precision. The random-fixnum function produces a non-heap-allocated positive integer with random bits.

Range expansion ↗

A solution with three main parts:

a parse-expression-grammar driven parser to decimate the input to a Lisp data structure;
some Lisp code to expand the list, sort it, and remove duplicates (recursion, hashing, sorting).
driver code which matches the input with the grammar, and produces output with the help of the Lisp code.

The grammar is:

num := [ + | - ] { digit } +

entry := num [ ws ] - [ ws ] num
      |  num

rangelist := entry [ ws ] , [ ws ] rangelist
          |  entry
          |  /* empty */

Code:

@(define num (n))@(local tok)@{tok /[+\-]?\d+/}@(bind n @(int-str tok))@(end)
@(define entry (e))@\
  @(local n1 n2)@\
  @(cases)@\
    @(num n1)@/\s*-\s*/@(num n2)@\
    @(bind e (n1 n2))@\
  @(or)@\
    @(num n1)@\
    @(bind e n1)@\
  @(end)@\
@(end)
@(define rangelist (list))@\
  @(local first rest)@\
  @(cases)@\
    @(entry first)@/\s*,\s*/@(rangelist rest)@\
    @(bind list @(cons first rest))@\
  @(or)@\
    @(entry first)@\
    @(bind list (first))@\
  @(or)@\
    @(bind list nil)@\
  @(end)@\
@(end)
@(do
   (defun expand-helper (list)
     (cond
       ((null list) nil)
       ((consp (first list))
        (append (range (first (first list))
                       (second (first list)))
                (rangeexpand (rest list))))
       (t (cons (first list) (rangeexpand (rest list))))))

   (defun rangeexpand (list)
     (uniq (expand-helper list))))
@(repeat)
@(rangelist x)@{trailing-junk}
@(output)
raw syntax: @x
expansion:  @(rangeexpand x)
your junk:  @{trailing-junk}
@(end)
@(end)

Run:

$ txr range-expansion.txr -
1,2,3-5,-3--1
raw syntax: 1 2 (3 5) (-3 -1)
expansion:  (-3 -2 -1 1 2 3 4 5)
your junk:
-6,-3--1,3-5,7-11,14,15,17-20
raw syntax: -6 (-3 -1) (3 5) (7 11) 14 15 (17 20)
expansion:  (-6 -3 -2 -1 3 4 5 7 8 9 10 11 14 15 17 18 19 20)
your junk:
-6,-3--1,3-5,7-11,14,15,17-20,cg@foo
raw syntax: -6 (-3 -1) (3 5) (7 11) 14 15 (17 20)
expansion:  (-6 -3 -2 -1 3 4 5 7 8 9 10 11 14 15 17 18 19 20)
your junk:  cg@foo

Note how the junk in the last example does not contain the trailing comma. This is because the rangelist grammar production allows for an empty range, so syntax like "5," is valid: it's an entry followed by a comma and a rangelist, where the rangelist is empty.

Range extraction ↗

(defun range-extract (numbers)
  `@{(mapcar [iff [callf > length (ret 2)]
                  (ret `@[@1 0]-@[@1 -1]`)
                  (ret `@{@1 ","}`)]
             (mapcar (op mapcar car)
                     (split [window-map 1 :reflect
                                        (op list @2 (- @2 @1))
                                        (sort (uniq numbers))]
                            (op where [chain second (op < 1)])))) ","}`)

Run:

$ txr
This is the TXR Lisp interactive listener of TXR 126.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (load "range.tl")
nil
2> (range-extract '(0 1 2 4 6 7 8 11 12 14 15 16 17 18 19 20 21 22 23 24 25 27 28 29 30 31 32 33 35 36 37 38 39))
"0-2,4,6-8,11,12,14-25,27-33,35-39"

Read a configuration file ↗

Prove the logic by transliterating to a different syntax:

@(collect)
@  (cases)
#@/.*/
@  (or)
;@/.*/
@  (or)
@{IDENT /[A-Z_][A-Z_0-9]+/}@/ */
@(bind VAL ("true"))
@  (or)
@{IDENT /[A-Z_][A-Z_0-9]+/}@(coll)@/ */@{VAL /[^,]+/}@/ */@(end)
@  (or)
@{IDENT /[A-Z_][A-Z_0-9]+/}@(coll)@/ */@{VAL /[^, ]+/}@/,? */@(end)
@(flatten VAL)
@  (or)
@/ */
@  (or)
@  (throw error "bad configuration syntax")
@  (end)
@(end)
@(output)
@  (repeat)
@IDENT = @(rep)@VAL, @(first){ @VAL, @(last)@VAL };@(single)@VAL;@(end)
@  (end)
@(end)

Sample run:

$ txr  configfile.txr  configfile
FULLNAME = Foo Barber;
FAVOURITEFRUIT = banana;
NEEDSPEELING = true;
OTHERFAMILY = { Rhu Barber, Harry Barber };

Read a specific line from a file ↗

From the top

Variable "line" matches and takes eighth line of input:

@(skip nil 7)
@line

From the bottom

Take the third line from the bottom of the file, if it exists.

@(skip)
@line
@(skip 1 2)
@(eof)

How this works is that the first skip will skip enough lines until the rest of the query successfully matches the input. The rest of the query matches a line, then skips two lines, and matches on EOF. So @line can only match at one location: three lines up from the end of the file. If the file doesn't have at least three lines, the query fails.

Read entire file ↗

@(next "foo.txt")
@(freeform)
@LINE

The freeform directive in TXR causes the remaining lines of the text stream to be treated as one big line, catenated together. The default line terminator is the newline "\n". This lets the entire input be captured into a single variable as a whole-line match.

Regular expressions ↗

Search and replace: simple

Txr is not designed for sed-like filtering, but here is how to do sed -e 's/dog/cat/g':

@(collect)
@(coll :gap 0)@mismatch@{match /dog/}@(end)@suffix
@(output)
@(rep)@{mismatch}cat@(end)@suffix
@(end)
@(end)

How it works is that the body of the coll uses a double-variable match: an unbound variable followed by a regex-match variable. The meaning of this combination is, "Search for the regular expression, and if successful, then bind all the characters whcih were skipped over by the search to the first variable, and the matching text to the second variable." So we collect pairs: pieces of mismatching text, and pieces of text which match the regex dog. At the end, there is usually going to be a piece of text which does not match the body, because it has no match for the regex. Because :gap 0 is specified, the coll construct will terminate when faced with this nonmatching text, rather than skipping it in a vain search for a match, which allows @suffix to take on this trailing text. To output the substitution, we simply spit out the mismatching texts followed by the replacement text, and then add the suffix.

Search and replace: strip comments from C source

Based on the technique of the previous example, here is a query for stripping C comments from a source file, replacing them by a space. Here, the "non-greedy" version of the regex Kleene operator is used, denoted by %. This allows for a very simple, straightforward regex which correctly matches C comments. The freeform operator allows the entire input stream to be treated as one big line, so this works across multi-line comments.

@(freeform)
@(coll :gap 0)@notcomment@{comment /[/][*].%[*][/]/}@(end)@tail
@(output)
@(rep)@notcomment @(end)@tail
@(end)

Regexes in TXR Lisp

Parse regex at run time to abstract syntax:

$ txr -p '(regex-parse "a.*b")'
(compound #\a (0+ wild) #\b)

Dynamically compile regex abstract syntax to regex object:

$ txr -p "(regex-compile '(compound #\a (0+ wild) #\b))"
#<sys:regex: 9c746d0>

Search replace with regsub.

$ txr -p '(regsub #/a+/ "-" "baaaaaad")'
"b-d"

Rename a file ↗

TXR works with native paths.

(rename-path "input.txt" "output.txt")
;; Windows (MinGW based port)
(rename-path "C:\\input.txt" "C:\\output.txt")
;; Unix; Windows (Cygwin port)
(rename-path "/input.txt" "/output.txt"))

Directories are renamed the same way; input.txt could be a directory.

Return multiple values ↗

TXR functions return material by binding unbound variables. The following function potentially returns three values, which will happen if called with three arguments, each of which is an unbound variable:

@(define func (x y z))
@  (bind w "discarded")
@  (bind (x y z) ("a" "b" "c"))
@(end)

The binding w, if created, is discarded because w is not in the list of formal parameters. However, w can cause the function to fail because there can already exist a variable w with a value which doesn't match "discarded". Call:

@(func t r s)

If t, r and s are unbound variables, they get bound to "a", "b" and "c", respectively via a renaming mechanism. This may look like C++ reference parameters or Pascal "var" parameters, and can be used that way, but isn't really the same at all. Failed call ("1" doesn't match "a"):

@(func "1" r s)

Successful call binding only one new variable:

@(func "a" "b" s)

Reverse words in a string ↗

Run from command line:

txr reverse.txr verse.txt

Solution:

@(collect)
@  (some)
@(coll)@{words /[^ ]+/}@(end)
@  (or)
@(bind words nil)
@  (end)
@(end)
@(set words @(mapcar (fun nreverse) words))
@(output)
@  (repeat)
@(rep)@words @(last)@words@(end)
@  (end)
@(end)

New line should be present after the last @(end) terminating vertical definition. i.e.

@(end)
[EOF]

not

@(end)[EOF]

Rot-13 ↗

Via definition and subsequent use of a named filter.

@(deffilter rot13
   ("a" "n") ("b" "o") ("c" "p") ("d" "q") ("e" "r") ("f" "s") ("g" "t")
   ("h" "u") ("i" "v") ("j" "w") ("k" "x") ("l" "y") ("m" "z") ("n" "a")
   ("o" "b") ("p" "c") ("q" "d") ("r" "e") ("s" "f") ("t" "g") ("u" "h")
   ("v" "i") ("w" "j") ("x" "k") ("y" "l") ("z" "m")
   ("A" "N") ("B" "O") ("C" "P") ("D" "Q") ("E" "R") ("F" "S") ("G" "T")
   ("H" "U") ("I" "V") ("J" "W") ("K" "X") ("L" "Y") ("M" "Z") ("N" "A")
   ("O" "B") ("P" "C") ("Q" "D") ("R" "E") ("S" "F") ("T" "G") ("U" "H")
   ("V" "I") ("W" "J") ("X" "K") ("Y" "L") ("Z" "M"))
@(repeat)
@line
@  (output :filter rot13)
@line
@  (end)
@(end)

Via TXR Lisp:

(defun rot13 (ch)
  (cond
    ((<= #\A ch #\Z) (wrap #\A #\Z (+ ch 13)))
    ((<= #\a ch #\z) (wrap #\a #\z (+ ch 13)))
    (t ch)))

   (whilet ((ch (get-char)))
     (put-char (rot13 ch)))

Runtime evaluation/In an environment ↗

Translation of Common Lisp

In TXR's embedded Lisp dialect, we can implement the same solution as Lisp or Scheme: transform the code fragment by wrapping a let around it which binds a variable, and then evaluating the whole thing:

(defun eval-subtract-for-two-values-of-x (code-fragment x1 x0)
  (- (eval ^(let ((x ,x1)) ,code-fragment))
     (eval ^(let ((x ,x0)) ,code-fragment))))

(eval-subtract-for-two-values-of-x 1 2) ;; yields -4.67077427047161

Cutting edge TXR code provides access to the environment manipulation functions, making this possible:

(defun eval-subtract-for-two-values-of-x (code-fragment x1 x0)
  (let ((e1 (make-env (list (cons 'x x1))))   ;; create two environments stuffed with binding for x
        (e0 (make-env (list (cons 'x x0)))))
    (- (eval code-fragment e1)                ;; pass these environment to eval
       (eval code-fragment e0))))
 
(eval-subtract-for-two-values-of-x '(exp x) 1 2)

Alternatively, empty environments can be made and extended with bindings:

(defun eval-subtract-for-two-values-of-x (code-fragment x1 x0)
  (let ((e1 (make-env))
        (e0 (make-env)))
    (env-vbind e1 'x x1)
    (env-vbind e0 'x x0)
    (- (eval code-fragment e1)
       (eval code-fragment e0))))
 
(eval-subtract-for-two-values-of-x '(exp x) 1 2)

Explicit environment manipulation has the disadvantage of being hostile against compiling. (See notes about compilation in the Common Lisp example.) there is an eval function which takes an environment parameter. However, currently there isn't any access to the manipulation of environment objects. It's probably a bad idea because run time tricks with lexical environments lead to programs that are not compilable. Lastly, we can also solve this problem using dynamically scoped (a.k.a "special") variables. The problem description specifically says that the solution is not to use global variables. Though we must define the variables as global, we do not use the global bindings; we use dynamic bindings. There is a hidden global variable, namely the dynamic environment itself. That's how eval is able to resolve the free-variable x occurring in code-fragment without receiving any environment parameter. However, our two let constructs carefully save and restore the dynamic environment (and therefore any prior value of x), even in the face of exceptions, and

(defvar x)

(defun eval-subtract-for-two-values-of-x (code-fragment x1 x0)
  (- (let ((x x1)) (eval code-fragment))
     (let ((x x0)) (eval code-fragment))))

(eval-subtract-for-two-values-of-x '(exp x) 1 2)

S-expressions ↗

TXR is in the Lisp family, and uses S-Expressions. So right from the system prompt we can do:

$ txr -p '(read)'
((data "quoted data" 123 4.5)
 (data (!@# (4.5) "(more" "data)")))
[Ctrl-D][Enter]
((data "quoted data" 123 4.5) (data (! (sys:var #(4.5)) "(more" "data)")))

However, note that the @ character has a special meaning: @obj turns into (sys:var obj). The purpose of this notation is to support Lisp code that requires meta-variables and meta-expressions. This can be used, for instance, in pattern matching to distinguish binding variables and matching operations from literal syntax. The following solution avoids "cheating" in this way with the built-in parser; it implements a from-scratch S-exp parser which treats !@# as just a symbol. The grammar is roughly as follows:


expr := ws? atom
     |  ws? ( ws? expr* ws? )

atom := float | int | sym | str

float := sign? digit+ . digit* exponent?
      |  sign? digit* . digit+ exponent?
      |  sign? digit+ exponent

int := sign? digit+

str := " (\" | anychar )* "

sym := sym-char +

sym-char := /* non-whitespace, but not ( and not ) */

Code:

@(define float (f))@\
  @(local (tok))@\
  @(cases)@\
    @{tok /[+\-]?\d+\.\d*([Ee][+\-]?\d+)?/}@\
  @(or)@\
    @{tok /[+\-]?\d*\.\d+([Ee][+\-]?\d+)?/}@\
  @(or)@\
    @{tok /[+\-]?\d+[Ee][+\-]?\d+/}@\
  @(end)@\
  @(bind f @(flo-str tok))@\
@(end)
@(define int (i))@\
  @(local (tok))@\
  @{tok /[+\-]?\d+/}@\
  @(bind i @(int-str tok))@\
@(end)
@(define sym (s))@\
  @(local (tok))@\
  @{tok /[^\s()]+/}@\
  @(bind s @(intern tok))@\
@(end)
@(define str (s))@\
  @(local (tok))@\
  @{tok /"(\\"|[^"])*"/}@\
  @(bind s @[tok 1..-1])@\
@(end)
@(define atom (a))@\
  @(cases)@\
    @(float a)@(or)@(int a)@(or)@(str a)@(or)@(sym a)@\
  @(end)@\
@(end)
@(define expr (e))@\
  @(cases)@\
    @/\s*/@(atom e)@\
  @(or)@\
    @/\s*\(\s*/@(coll :vars (e))@(expr e)@/\s*/@(last))@(end)@\
  @(end)@\
@(end)
@(freeform)
@(expr e)@junk
@(output)
expr: @(format nil "~s" e)
junk: @junk
@(end)

Run:

$ txr s-expressions.txr -
() 
expr: nil
junk: 
$ txr s-expressions.txr -
3e3
expr: 3000.0
junk: 
$ txr s-expressions.txr -
+3
expr: 3
junk: 
$ txr s-expressions.txr -
abc*
expr: abc*
junk: 
$ txr s-expressions.txr -
abc*)
expr: abc*
junk: )
$ txr s-expressions.txr -
((data "quoted data" 123 4.5)
 (data (!@# (4.5) "(more" "data)")))
expr: ((data "quoted data" 123 4.5) (data (!@# (4.5) "(more" "data)")))
junk:

TODO: Note that the recognizer for string literals does not actually process the interior escape sequences \"; these remain as part of the string data. The only processing is the stripping of the outer quotes from the lexeme. Explanation of most confusing line:

    @/\s*\(\s*/@(coll :vars (e))@(expr e)@/\s*/@(last))@(end)

First, we match an open parenthesis that can be embedded in whitespace. Then we have a @(coll) construct which terminates with @(end). This is a repetition construct for collecting zero or more items. The :vars (e) argument makes the collect strict: each repetition must bind the variable e. More importantly, in this case, if nothing is collected, then e gets bound to nil (the empty list). The collect construct does not look at context beyond itself. To terminate the collect at the closing parenthesis we use @(last)). The second closing parenthesis here is literal text to be matched, not TXR syntax. This special clause establishes the terminating context without which the collect will munge all input. When the last clause matches, whatever it matches is consumed and the collect ends. (There is a related @(until) clause which terminates the collect, but leaves its own match unconsumed.)

Scope modifiers ↗

Functions and filters are global in TXR. Variables are pattern matching variables and have a dynamically scoped discipline. The binding established in a clause is visible to other clauses invoked from that clause, including functions. Whether or not bindings survive from a given scope usually depends on whether the scope, overall, failed or succeeded. Bindings established in scopes that terminate by failing (or by an exception) are rolled back and undone. The @(local) or @(forget) directives, which are synonyms, are used for breaking the relationship between variables occuring in a scope, and any bindings those variables may have. If a clause declares a variable forgotten, but then fails, then this forgetting is also undone; the variable is known once again. But in successful situations, the effects of forgetting can be passed down. Functions have special scoping and calling rules. No binding for a variable established in a function survives the execution of the function, except if its symbol matches one of the function parameters, call it P, and that parameter is unbound (i.e. the caller specified some unbound variable A as the argument). In that case, the new binding for unbound parameter P within the function is translated into a new binding for unbound argument A at the call site. Of course, this only happens if the function succeeds, otherwise the function call is a failure with no effect on the bindings. Illustration using named blocks. In the first example, the block succeeds and so its binding passes on:

@(maybe)@# perhaps this subclause suceeds or not
@  (block foo)
@  (bind a "a")
@  (accept foo)
@(end)
@(bind b "b")

Result (with -B option to dump bindings):

a="a"
b="b"

By contrast, in this version, the block fails. Because it is contained in a @(maybe), evaluation can proceed, but the binding for a is gone.

@(maybe)@# perhaps this subclause suceeds or not
@  (block foo)
@  (bind a "a")
@  (fail foo)
@(end)
@(bind b "b")

Result (with -B):

b="b"

Send email ↗

#!/usr/bin/txr
@(next :args)
@(cases)
@TO
@SUBJ
@  (maybe)
@CC
@  (or)
@  (bind CC "")
@  (end)
@(or)
@  (throw error "must specify at least To and Subject")
@(end)
@(next *stdin*)
@(collect)
@BODY
@(end)
@(output (open-command `mail -s "@SUBJ" -a CC: "@CC" "@TO"` "w"))
@(repeat)
@BODY
@(end)
.
@(end)

Output:

$ ./sendmail.txr linux-kernel@vger.kernel.org "Patch to rewrite scheduler #378"
Here we go
again ...
[Ctrl-D]
$

Set consolidation ↗

Original solution:

(defun mkset (p x) (set [p x] (or [p x] x)))

(defun fnd (p x) (if (eq [p x] x) x (fnd p [p x])))

(defun uni (p x y)
  (let ((xr (fnd p x)) (yr (fnd p y)))
    (set [p xr] yr)))

(defun consoli (sets)
  (let ((p (hash)))
    (each ((s sets))
      (each ((e s))
        (mkset p e)
        (uni p e (car s))))
    (hash-values
      [group-by (op fnd p) (hash-keys
                             [group-by identity (flatten sets)])])))

;; tests

(each ((test '(((a b) (c d))
               ((a b) (b d))
               ((a b) (c d) (d b))
               ((h i k) (a b) (c d) (d b) (f g h)))))
  (format t "~s -> ~s\n" test (consoli test)))

Output:

((a b) (c d)) -> ((b a) (d c))
((a b) (b d)) -> ((b a d))
((a b) (c d) (d b)) -> ((b a d c))
((h i k) (a b) (c d) (d b) (f g h)) -> ((g f k i h) (b a d c)

Translation of Racket

(defun mkset (items) [group-by identity items])

(defun empty-p (set) (zerop (hash-count set)))

(defun consoli (ss)
  (defun combi (cs s)
    (cond ((empty-p s) cs)
          ((null cs) (list s))
          ((empty-p (hash-isec s (first cs)))
           (cons (first cs) (combi (rest cs) s)))
          (t (consoli (cons (hash-uni s (first cs)) (rest cs))))))
  [reduce-left combi ss nil])

;; tests
(each ((test '(((a b) (c d))
               ((a b) (b d))
               ((a b) (c d) (d b))
               ((h i k) (a b) (c d) (d b) (f g h)))))
  (format t "~s -> ~s\n" test
          [mapcar hash-keys (consoli [mapcar mkset test])]))

Output:

((a b) (c d)) -> ((b a) (d c))
((a b) (b d)) -> ((d b a))
((a b) (c d) (d b)) -> ((d c b a))
((h i k) (a b) (c d) (d b) (f g h)) -> ((g f k i h) (d c b a))

SHA-256 ↗

1> (sha256 "Rosetta code")
#b'764faf5c61ac315f 1497f9dfa5427139 65b785e5cc2f707d 6468d7d1124cdfcf'

Shell one-liner ↗

$ echo 123-456-7890 | txr -c '@a-@b-@c' -
a="123"
b="456"
c="7890"

Most useful txr queries consist of multiple lines, and the line structure is important. Multi-liners can be passed via -c easily, but there is no provision in the syntax that would allow multi-liners to be actually written as one physical line. There are opposite provisions for splitting long logical lines into multiple physical lines. The -e (evaluate) and -p (evaluate and print) options provide shell one-liner access to TXR Lisp:

$ txr -p '(+ 2 2)'
4

$ txr -e '(mkdir "foo" #o777)'
$ ls -ld foo
drwxrwxr-x 2 kaz kaz 4096 Mar  4 23:36 foo

Short-circuit evaluation ↗

@(define a (x out))
@  (output)
  a (@x) called
@  (end)
@  (bind out x)
@(end)
@(define b (x out))
@  (output)
  b (@x) called
@  (end)
@  (bind out x)
@(end)
@(define short_circuit_demo (i j))
@  (output)
a(@i) and b(@j):
@  (end)
@  (maybe)
@    (a i "1")
@    (b j "1")
@  (end)
@  (output)
a(@i) or b(@j):
@  (end)
@  (cases)
@    (a i "1")
@  (or)
@    (b j "1")
@  (or)
@    (accept)
@  (end)
@(end)
@(short_circuit_demo "0" "0")
@(short_circuit_demo "0" "1")
@(short_circuit_demo "1" "0")
@(short_circuit_demo "1" "1")

Run:

$ txr short-circuit-bool.txr 
a(0) and b(0):
  a (0) called
a(0) or b(0):
  a (0) called
  b (0) called
a(0) and b(1):
  a (0) called
a(0) or b(1):
  a (0) called
  b (1) called
a(1) and b(0):
  a (1) called
  b (0) called
a(1) or b(0):
  a (1) called
a(1) and b(1):
  a (1) called
  b (1) called
a(1) or b(1):
  a (1) called

The a and b functions are defined such that the second parameter is intended to be an unbound variable. When the function binds out, that value propagates back to the unbound variable at the call site. But the way calls works in this language allows us to specify a value instead such as "1". So now the directive @(bind out x) performs unification instead: if x doesn't match "1", the function fails, otherwise it succeeds. So simply by placing two calls consecutively, we get a short circuting conjunction. The second will not execute if the first one fails. Short-circuiting disjunction is provided by @(cases). The @(maybe) construct stops failure from propagating from the enclosed subquery. The @(accept) directive will bail out of the closest enclosing anonymous block (the function body) with a success. It prevents the @(cases) from failing the function if neither case is successful.

Show ASCII table ↗

(let ((spcdel (relate " \x7f" #("Spc" "Del"))))
  (each ((r 32..48))
    (each ((c (take 6 (range r : 16))))
      (put-string (pic "###: <<<" c [spcdel (chr-num c)])))
    (put-line)))

Output:

 32: Spc 48: 0   64: @   80: P   96: `  112: p  
 33: !   49: 1   65: A   81: Q   97: a  113: q  
 34: "   50: 2   66: B   82: R   98: b  114: r  
 35: #   51: 3   67: C   83: S   99: c  115: s  
 36: $   52: 4   68: D   84: T  100: d  116: t  
 37: %   53: 5   69: E   85: U  101: e  117: u  
 38: &   54: 6   70: F   86: V  102: f  118: v  
 39: '   55: 7   71: G   87: W  103: g  119: w  
 40: (   56: 8   72: H   88: X  104: h  120: x  
 41: )   57: 9   73: I   89: Y  105: i  121: y  
 42: *   58: :   74: J   90: Z  106: j  122: z  
 43: +   59: ;   75: K   91: [  107: k  123: {  
 44: ,   60: <   76: L   92: \  108: l  124: |  
 45: -   61: =   77: M   93: ]  109: m  125: }  
 46: .   62: >   78: N   94: ^  110: n  126: ~  
 47: /   63: ?   79: O   95: _  111: o  127: Del

Singleton ↗

;; Custom (:singleton) clause which adds behavior to a class
;; asserting against multiple instantiation.
(define-struct-clause :singleton ()
  ^((:static inst-count 0)
    (:postinit (me)
      (assert (<= (inc me.inst-count) 1)))))

(defstruct singleton-one ()
  (:singleton)
  (:method speak (me)
    (put-line "I am singleton-one")))

(defstruct singleton-two ()
  (:singleton)
  (:method speak (me)
    (put-line "I am singleton-two")))

;; Test

;; Global singleton
(defvarl s1 (new singleton-one))

;; Local singleton in function (like static in C)
;; load-time evaluates once.
(defun fn ()
  (let ((s2 (load-time (new singleton-two))))
    s2.(speak)))

s1.(speak)
(fn) ;; multiple calls to fn don't re-instantiate singleton-two
(fn)
(put-line "so far, so good")
(new singleton-two) ;; assertion gooes off

Output:

I am singleton-one
I am singleton-two
I am singleton-two
so far, so good
txr: unhandled exception of type assert:
txr: assertion (<= (inc me.inst-count)
                   1) failed in singleton.tl:6

txr: during evaluation at singleton.tl:6 of form (sys:rt-assert-fail "singleton.tl"
                                                                     6 '(<= (inc me.inst-count)
                                                                            1))

Sleep ↗

(let ((usec (progn (put-string "enter sleep usecs: ")
                   (tointz (get-line)))))
  (put-string "Sleeping ... ")
  (flush-stream)
  (usleep usec)
  (put-line "Awake!"))

Smallest square that begins with n ↗

One Pass Through Squares

In this solution we avoid calculating squares; no multiplication occurs in the code. We generate successive squares using a recurrence relation. We also avoid doing a starts-with test using digits. Rather, we take each successive square and begin repeatedly dividing it by 10, with a truncating division. Whenever the quotient fits into the range 0 to 49 (valid index for our output table) we check whether the entry at that position is nil. If so, this is the smallest square which begins with the digits of that position and we put it into the table there. When 49 numbers have been placed, indicated by an incrementing counter, the algorithm ends. The [out 0] entry is left null.

(for ((cnt 49) (n 1) (sq 1) (st 3) (out (vector 50)))
     ((plusp cnt) (each ((x 1..50))
                    (put-line (pic "## ########" x [out x]))))
     ((inc sq st) (inc st 2) (inc n))
  (for ((xsq sq)) ((plusp xsq)) ((set xsq (trunc xsq 10)))
    (when (and (< xsq 50) (null [out xsq]))
      (set [out xsq] sq)
      (dec cnt))))

Output:

 1        1
 2       25
 3       36
 4        4
 5      529
 6       64
 7      729
 8       81
 9        9
10      100
11     1156
12      121
13     1369
14      144
15     1521
16       16
17     1764
18     1849
19      196
20     2025
21     2116
22      225
23     2304
24     2401
25       25
26     2601
27     2704
28      289
29     2916
30     3025
31     3136
32      324
33     3364
34     3481
35    35344
36       36
37     3721
38     3844
39     3969
40      400
41    41209
42     4225
43     4356
44      441
45    45369
46     4624
47     4761
48      484
49       49

Terse

The following inefficient-but-terse solution produces the same output:

(each ((n 1..50))
  (flow [mapcar* square 1]
        (find-if (opip digits (starts-with (digits n))))
        (pic "## ########" n)
        put-line))

Loopy

Translation of BASIC

(each ((i 1..50))
  (block search
    (each ((j 1))
      (for ((k (square j)))
           ((> k i) (when (eql k i)
                      (put-line (pic "## ########" i (square j)))
                      (return-from search)))
           ((set k (trunc k 10)))))))

Sockets ↗

(let* ((server (first (getaddrinfo "localhost" 256)))
       (sock (open-socket server.family sock-stream)))
  (sock-connect sock server)
  (put-string "hello socket world"))

Sort stability ↗

TXR provides a number of sorting functions. sort and nsort (destructive variant) are not stable for vectors and strings, but are stable for lists. The functions ssort and snsort counterparts are stable for all sequence kinds. In addition, there are caching variants of all these functions: csort, cnsort, cssort and csnsort. They respectively have the same stability properties as their counterparts without the leading c. TXR Lisp originally had one sorting function called sort, which was destructive, like the sort in Common Lisp. That function was renamed to nsort, and sort became the name of a non-destructive function. That happened in TXR 238, released in May, 2020.

Sort three variables ↗

The following is a comprehensive solution to the general problem of sorting any number of mutable places. We develop a macro operator called sort-places which is called with zero or more argument expressions that denote assignable places. The places are sorted in order according to the greater function. The zero and one argument cases are handled as no-ops; the arguments are not evaluated at all, even for their side effects if they have any. The two argument case is handled by generating a conditional which controls a single swap. The three-argument case performs up to three swaps. For four or more arguments, a hidden vector object is generated. The values of the places are stuffed into the vector, which is then sorted, after which the values are retrieved and stored in the places. All cases work in such a way that the place expressions are evaluated at most once, which is achieved by leveraging the simple-to-use placelet macro.

(defmacro sort-places (. places)
  (caseql (len places)
    ((0 1) nil)
    (2 (with-gensyms (p0 p1)
         ^(placelet ((p0 (read-once ,[places 0]))
                     (p1 (read-once ,[places 1])))
            (if (greater p0 p1)
              (swap p0 p1)))))
    (3 (with-gensyms (p0 p1 p2)
         ^(placelet ((p0 (read-once ,[places 0]))
                     (p1 (read-once ,[places 1]))
                     (p2 (read-once ,[places 2])))
            (if (greater p0 p1)
              (swap p0 p1))
            (if (greater p1 p2)
              (swap p1 p2))
            (if (greater p0 p1)
              (swap p0 p1)))))
    (t (let ((gens [mapcar (ret (gensym)) places]))
         (with-gensyms (vec)
           ^(placelet ,(zip gens places)
              (let ((,vec (vec ,*gens)))
                (nsort ,vec)
                (set ,*(append-each ((g gens)
                                     (i 0))
                         ^(,g [,vec ,i]))))))))))

(prinl (sort-places))

(let ((x 1))
  (sort-places x)
  (prinl x))

(let ((x 2)
      (y 1))
  (sort-places x y)
  (prinl (list x y)))

(let ((a 3)
      (b 2)
      (c 1))
  (sort-places a b c)
  (prinl (list a b c)))

(let ((a 4)
      (b 3)
      (c 2)
      (d 1))
  (sort-places a b c d)
  (prinl (list a b c d)))

Output:

nil
1
(1 2)
(1 2 3)
(1 2 3 4)

Soundex ↗

TXR Pattern Language

This implements the full Soundex described in U.S. National Archives Website . Doubled letters are condensed before separating the first letter, so that for instance "Lloyd" is not treated as L followed by the coding of LOYD but as L followed by the coding of OYD. Consecutive consonants which map to the same code are not condensed to a single occurrence of the code if they are separated by vowels, but separating W and H do not thus intervene. Names with common prefixes are encoded in two ways.

@(next :args)
@###
@# soundex-related filters
@###
@(deffilter remdbl ("AA" "A") ("BB" "B") ("CC" "C") ("DD" "D") ("EE" "E")
                   ("FF" "F") ("GG" "G") ("HH" "H") ("II" "I") ("JJ" "J")
                   ("KK" "K") ("LL" "L") ("MM" "M") ("NN" "N") ("OO" "O")
                   ("PP" "P") ("QQ" "Q") ("RR" "R") ("SS" "S") ("TT" "T")
                   ("UU" "U") ("VV" "V") ("WW" "W") ("XX" "X") ("YY" "Y")
                   ("ZZ" "Z"))
@(deffilter code ("B" "F" "P" "V" "1")
                 ("C" "G" "J" "K" "Q" "S" "X" "Z" "2")
                 ("D" "T" "3") ("L" "4") ("M" "N" "5")
                 ("R" "6") ("A" "E" "I" "O" "U" "Y" "0") ("H" "W" ""))
@(deffilter squeeze ("11" "111" "1111" "11111" "1")
                    ("22" "222" "2222" "22222" "2")
                    ("33" "333" "3333" "33333" "3")
                    ("44" "444" "4444" "44444" "4")
                    ("55" "555" "5555" "55555" "5")
                    ("66" "666" "6666" "66666" "6"))
@(bind prefix ("VAN" "CON" "DE" "DI" "LA" "LE"))
@(deffilter remzero ("0" ""))
@###
@# soundex function
@###
@(define soundex (in out))
@  (local nodouble letters remainder first rest coded)
@  (next :string in)
@  (coll)@{letters /[A-Za-z]+/}@(end)
@  (cat letters "")
@  (output :into nodouble :filter (:upcase remdbl))
@letters
@  (end)
@  (next :list nodouble)
@  (maybe)
@prefix@remainder
@    (output :into nodouble)
@nodouble
@remainder
@    (end)
@  (end)
@  (next :list nodouble)
@  (collect)
@{first 1}@rest
@    (output :filter (code squeeze remzero) :into coded)
@{rest}000
@    (end)
@    (next :list coded)
@{digits 3}@(skip)
@  (end)
@  (output :into out)
@    (rep):@first@digits@(first)@first@digits@(end)
@  (end)
@  (cat out)
@(end)
@###
@# process arguments and list soundex codes
@###
@(collect :vars ())
@input
@  (output :filter (:fun soundex))
@input
@  (end)
@(end)
@###
@# compare first and second argument under soundex
@###
@(bind (first_arg second_arg . rest_args) input)
@(cases)
@  (bind first_arg second_arg :filter (:fun soundex))
@  (output)
"@first_arg" and "@second_arg" match under soundex
@  (end)
@(end)

Run:

$ txr soundex.txr example soundex Lloyd lee guttierez o\'hara vandeusen dimeola
E251
E251
S532
L300
L000
G362
O600
V532:D250
D540:M400
"example" and "egsampul" match under soundex

With TXR Lisp

This solution is similar to some of the solutions in other languages. Its treatment of the algorithm is not as complete as the above solution.

@(do (defun get-code (c)
       (caseq c
         ((#\B #\F #\P #\V) #\1)
         ((#\C #\G #\J #\K #\Q #\S #\X #\Z) #\2)
         ((#\D #\T) #\3)
         (#\L #\4)
         ((#\M #\N) #\5)
         (#\R #\6)))

     (defun soundex (s)
       (if (zerop (length s))
         ""
         (let* ((su (upcase-str s))
                (o [su 0]))
           (for ((i 1) (l (length su)) cp cg)
                ((< i l) [`@{o}000` 0 4])
                ((inc i) (set cp cg))
             (set cg (get-code [su i]))
             (if (and cg (not (eql cg cp)))
               (set o `@o@cg`)))))))
@(next :args)
@(repeat)
@arg
@  (output)
@arg -> @(soundex arg)
@  (end)
@(end)

Run:

$ ./txr soundex-lisp.txr  soundex sowndex
soundex -> S532
sowndex -> S532

Special characters ↗

Text not containing the character @ is a TXR query representing a match that text. The sequence @@ encodes a single literal @. All other special syntax is introduced by @:

@# comment
@\n # escaped character, embedded into surrounding text. Similar to C escapes, with \e for ASCII ESC.
@\x1234 @\1234 Hex or octal escapes: Unicode width, not byte.
@symbol variable ref
@*symbol variable ref with longest match semantics
@{symbol expr ...} variable ref extended syntax
@expr directive

Where expr is Lispy syntax which can be an atom, or a list of atoms or lists in parentheses, or possibly a dotted list (terminated by an atom other than nil):

(elem1 elem2 ... elemn) proper
(elem1 elem2 ... elemn . atom) dotted

Atoms can be:

ABc123_4 symbols, represented by tokens consisting of letters, underscores and digits, beginning with a letter. Symbols have packages, e.g., system:foo, but this is not accessible from the TXR lexical conventions.
:FoO42 keyword symbols, denoted by colon, which is not part of the symbol name.
"string literals"
`quasi @literals` with embedded @ syntax
'c' characters
123 integers
/reg/ regular expressions

Within literals and regexes:

\r various backslash escapes similar to C
\\ single backslash

Within literals, quasiliterals and character constants:

\' \" \` escape any of the quotes: not available within regex.

The regex syntax is fairly standard fare, with these extensions:

~R complement of R: set of strings other than those that match R
R%S match shortest number of repetitions of R prior to S.
R&S match R and S simultaneously: the intersection of the set of strings matching S and the set matching R.
[] empty class; match nothing, not even the empty string.

String matching ↗

TXR Lisp

(tree-case *args*
  ((big small)
   (cond
     ((< (length big) (length small))
      (put-line `@big is shorter than @small`))
     ((str= big small)
      (put-line `@big and @small are equal`))
     ((starts-with small big)
      (put-line `@small is a prefix of @big`))
     ((ends-with small big)
      (put-line `@small is a suffix of @big`))
     (t (iflet ((pos (search-str big small)))
          (put-line `@small occurs in @big at position @pos`)
          (put-line `@small does not occur in @big`)))))
  (otherwise
    (put-line `usage: @(ldiff *full-args* *args*) <bigstring> <smallstring>`)))

Output:

$ txr cmatch2.tl x
usage: txr cmatch2.tl <bigstring> <smallstring>
$ txr cmatch2.tl x y z
usage: txr cmatch2.tl <bigstring> <smallstring>
$ txr cmatch2.tl catalog cat
cat is a prefix of catalog
$ txr cmatch2.tl catalog log
log is a suffix of catalog
$ txr cmatch2.tl catalog at
at occurs in catalog at position 1
$ txr cmatch2.tl catalog catalogue
catalog is shorter than catalogue
$ txr cmatch2.tl catalog catalog
catalog and catalog are equal
$ txr cmatch2.tl catalog dog
dog does not occur in catalog

Pattern Language

@line
@(cases)
@  line
@  (output)
second line is the same as first line
@  (end)
@(or)
@  (skip)@line
@  (output)
first line is a suffix of the second line
@  (end)
@(or)
@  line@(skip)
@  (output)
first line is a suffix of the second line
@  (end)
@(or)
@  prefix@line@(skip)
@  (output)
first line is embedded in the second line at position @(length prefix)
@  (end)
@(or)
@  (output)
first line is not found in the second line
@  (end)
@(end)

Output:

$ txr cmatch.txr -
123
01234
first line is embedded in the second line at position 1
$ txr cmatch.txr -
123
0123
first line is a suffix of the second line

Strip a set of characters from a string ↗

This solution builds up a regular expression in a hygienic way from the set of characters given as a string. The string is broken into a list, which is used to construct a regex abstract syntax tree for a character set match, using a Lisp quasiquote. This is fed to the regex compiler, which produces an executable machine that is then used with regsub. On the practical side, some basic structural pattern matching is used to process command line argument list. Since the partial argument list (the arguments belonging to the TXR script) is a suffix of the full argument list (the complete arguments which include the invoking command and the script name), the classic Lisp function ldiff comes in handy in obtaining just the prefix, for printing the usage:

(defun strip-chars (str set)
  (let* ((regex-ast ^(set ,*(list-str set)))
         (regex-obj (regex-compile regex-ast)))
    (regsub regex-obj "" str)))

(defun usage ()
  (pprinl `usage: @{(ldiff *full-args* *args*) " "} <string> <set>`)
  (exit 1))

(tree-case *args*
  ((str set extra) (usage))
  ((str set . junk) (pprinl (strip-chars str set)))
  (else (usage)))

Output:

$ txr strip-chars-2.tl
usage: txr strip-chars-2.tl <string> <set>
$ txr strip-chars-2.tl "she was a soul stripper. she stole my heart." "aei"
sh ws  soul strppr. sh stol my hrt.

Now here is a rewrite of strip-chars which just uses classic Lisp that has been generalized to work over strings, plus the do syntax (a sibling of the op operator) that provides syntactic sugar for a lambda function whose body is an operator or macro form.

(defun strip-chars (str set)
   (mappend (do if (memq @1 set) (list @1)) str))

(do if (memq @1 set) (list @1)) is just (lambda (item) (if (memq item set) (list item))). mappend happily maps over strings and since the leftmost input sequence is a string, and the return values of the lambda are sequence of characters, mappend produces a string.

Strip control codes and extended characters from a string ↗

Translation of Racket

(defun strip-controls (str)
 (regsub #/[\x0-\x1F\x7F]+/ "" str))

(defun strip-controls-and-extended (str)
  (regsub #/[^\x20-\x7F]+/ "" str))

Strip whitespace from a string/Top and tail ↗

Pattern Matching Language Exercise

Here, no builtin functions are used, just text pattern matching logic. Two functions are written, conforming to the proper filter convention, and then employed as filters.

@(define trim_left (in out))
@  (next :list in)
@/[ \t]*/@out
@(end)
@(define trim_right (in out))
@  (local blanks middle)
@  (next :list in)
@  (cases)
@    {blanks /[ \t]*/}@middle@/[\t ]+/
@    (bind out `@blanks@middle`)
@  (or)
@    out
@  (end)
@(end)
@line_of_input
@(output)
trim-left:  [@{line_of_input :filter (:fun trim_left)}]
trim_right: [@{line_of_input :filter (:fun trim_right)}]
trim_both:  [@{line_of_input :filter ((:fun trim_left) (:fun trim_right))}]
@(end)

Output:

$ echo "" | txr trim.txr  -
trim-left:  []
trim_right: []
trim_both:  []
$ echo "a" | txr trim.txr  -
trim-left:  [a]
trim_right: [a]
trim_both:  [a]
$ echo " a" | txr trim.txr  -
trim-left:  [a]
trim_right: [ a]
trim_both:  [a]
$ echo " a " | txr trim.txr  -
trim-left:  [a ]
trim_right: [ a]
trim_both:  [a]
$ echo " a b " | txr trim.txr  -
trim-left:  [a b ]
trim_right: [ a b]
trim_both:  [a b]

Using Lisp Primitives

Trimming whitespace from both ends is a builtin:

$ txr -p '(trim-str " a b ")'
"a b"

An unnecessarily cryptic, though educational, left trim:

$ txr -p '[(do progn (del [@1 0..(match-regex @1 #/\s*/)]) @1) " a b "]'
"a b "

Explanation: the basic structure is [function " a b "] where the function is an anonymous lambda generated using the do operator. The function is applied to the string " a b ". The structure of the do is (do progn (blah @1) @1) where the forms make references to implicit argument @1, and so the generated lambda has one argument, essentially being: (lambda (arg) (blah arg) arg): do something with the argument (the string) and then return it. What is done with the argument is this: (del [@1 0..(match-regex @1 #/\s+/)]). The match-regex function returns the number of characters at the front of the string which match the regex \s*: one or more spaces. The return value of this is used to express a range 0..length which is applied to the string. The syntax (del [str from..to]) deletes a range of characters in the string. Lastly, a pedestrian right trim:

(defun trim-right (str)
  (for ()
       ((and (> (length str) 0) (chr-isspace [str -1])) str)
       ((del [str -1]))))
(format t "{~a}\n" (trim-right " a a "))
(format t "{~a}\n" (trim-right "  "))
(format t "{~a}\n" (trim-right "a "))
(format t "{~a}\n" (trim-right ""))

Output:

{ a a}
{}
{a}
{}

Sum of a series ↗

Reduce with + operator over a lazily generated list. Variant A1: limit the list generation inside the gen operator.

txr -p '[reduce-left + (let ((i 0)) (gen (< i 1000) (/ 1.0 (* (inc i) i)))) 0]'
1.64393456668156

Variant A2: generate infinite list, but take only the first 1000 items using [list-expr 0..999].

txr -p '[reduce-left + [(let ((i 0)) (gen t (/ 1.0 (* (inc i) i)))) 0..999] 0]'
1.64393456668156

Variant B: generate lazy integer range, and pump it through a series of function with the help of the chain functional combinator and the op partial evaluation/binding operator.

txr -p '[[chain range (op mapcar (op / 1.0 (* @1 @1))) (op reduce-left + @1 0)] 1 1000]'
1.64393456668156

Variant C: unravel the chain in Variant B using straightforward nesting.

txr -p '[reduce-left + (mapcar (op / 1.0 (* @1 @1)) (range 1 1000)) 0]'
1.64393456668156

Variant D: bring Variant B's inverse square calculation into the fold, eliminating mapcar. Final answer.

txr -p '[reduce-left (op + @1 (/ 1.0 (* @2 @2))) (range 1 1000) 0]'
1.64393456668156

Summarize and say sequence ↗

Translation of Clojure

This is a close, almost expression-by-expression transliteration of the Clojure version.

;; Syntactic sugar for calling reduce-left
(defmacro reduce-with ((acc init item sequence) . body)
  ^(reduce-left (lambda (,acc ,item) ,*body) ,sequence ,init))

 ;; Macro similar to clojure's ->> and ->
(defmacro opchain (val . ops)
  ^[[chain ,*[mapcar [iffi consp (op cons 'op)] ops]] ,val])

;; Reduce integer to a list of integers representing its decimal digits.
(defun digits (n)
  (if (< n 10)
    (list n)
    (opchain n tostring list-str (mapcar (op - @1 #\0)))))

(defun dcount (ds)
  (digits (length ds)))

;; Perform a look-say step like (1 2 2) --"one 1, two 2's"-> (1 1 2 2).
(defun summarize-prev (ds)
  (opchain ds copy (sort @1 >) (partition-by identity)
           (mapcar [juxt dcount first]) flatten))

;; Take a starting digit string and iterate the look-say steps,
;; to generate the whole sequence, which ends when convergence is reached.
(defun convergent-sequence (ds)
  (reduce-with (cur-seq nil ds [giterate true summarize-prev ds])
    (if (member ds cur-seq)
      (return-from convergent-sequence cur-seq)
      (nconc cur-seq (list ds)))))

;; A candidate sequence is one which begins with montonically
;; decreasing digits. We don't bother with (9 0 9 0) or (9 0 0 9);
;; which yield identical sequences to (9 9 0 0).
(defun candidate-seq (n)
  (let ((ds (digits n)))
    (if [apply >= ds]
      (convergent-sequence ds))))

;; Discover the set of longest sequences.
(defun find-longest (limit)
  (reduce-with (max-seqs nil new-seq [mapcar candidate-seq (range 1 limit)])
    (let ((cmp (- (opchain max-seqs first length) (length new-seq))))
      (cond ((> cmp 0) max-seqs)
            ((< cmp 0) (list new-seq))
            (t (nconc max-seqs (list new-seq)))))))

(defvar *results* (find-longest 1000000))

(each ((result *results*))
  (flet ((strfy (list) ;; (strfy '((1 2 3 4) (5 6 7 8))) -> ("1234" "5678")
           (mapcar [chain (op mapcar tostring) cat-str] list)))
    (let* ((seed (first result))
           (seeds (opchain seed perm uniq (remove-if zerop @1 first))))
      (put-line `Seed value(s): @(strfy seeds)`)
      (put-line)
      (put-line `Iterations: @(length result)`)
      (put-line)
      (put-line `Sequence: @(strfy result)`))))

Output:

$ txr self-ref-seq.tl

Seed value(s): 9900 9090 9009

Iterations: 21

Sequence: 9900 2920 192210 19222110 19323110 1923123110 1923224110 191413323110 191433125110 19151423125110 19251413226110 1916151413325110 1916251423127110 191716151413326110 191726151423128110 19181716151413327110 19182716151423129110 29181716151413328110 19281716151423228110 19281716151413427110 19182716152413228110

Translation of Common Lisp

Mostly the same logic. The count-and-say function is based on the same steps, but stays in the string domain instead of converting the input to a list, and then the output back to a string. It also avoids building the output backwards and reversing it, so out must be accessed on the right side inside the loop. This is easy due to Python-inspired array indexing semantics: -1 means last element, -2 second last and so on. Like in Common Lisp, TXR's sort is destructive, so we take care to use copy-str.

(defun count-and-say (str)
  (let* ((s [sort (copy-str str) <])
         (out `@[s 0]0`))
    (each ((x s))
      (if (eql x [out -1])
        (inc [out -2])
        (set out `@{out}1@x`)))
    out))

(defun ref-seq-len (n : doprint)
  (let ((s (tostring n)) hist)
    (while t
      (push s hist)
      (if doprint (pprinl s))
      (set s (count-and-say s))
      (each ((item hist)
             (i (range 0 2)))
        (when (equal s item)
          (return-from ref-seq-len (length hist)))))))

(defun find-longest (top)
  (let (nums (len 0))
    (each ((x (range 0 top)))
      (let ((l (ref-seq-len x)))
        (when (> l len) (set len l) (set nums nil))
        (when (= l len) (push x nums))))
    (list nums len)))

Output:

Longest: ((9900 9090 9009 99) 21)
9900
2029
102219
10212219
10313219
1031122319
1041222319
103132131419
105112331419
10511223141519
10612213142519
1051321314151619
1071122314251619
106132131415161719
108112231415261719
10713213141516171819
10911223141516271819
10813213141516171829
10812223141516172819
10714213141516172819
10812213241516271819

Translation of Racket

;; Macro very similar to Racket's for/fold
(defmacro for-accum (accum-var-inits each-vars . body)
  (let ((accum-vars [mapcar first accum-var-inits])
        (block-sym (gensym))
        (next-args [mapcar (ret (progn @rest (gensym))) accum-var-inits])
        (nvars (length accum-var-inits)))
    ^(let ,accum-var-inits
       (flet ((iter (,*next-args)
                ,*[mapcar (ret ^(set ,@1 ,@2)) accum-vars next-args]))
         (each ,each-vars
           ,*body)
         (list ,*accum-vars)))))

(defun next (s)
  (let ((v (vector 10 0)))
    (each ((c s))
      (inc [v (- #\9 c)]))
    (cat-str
      (collect-each ((x v)
                     (i (range 9 0 -1)))
        (when (> x 0)
          `@x@i`)))))

(defun seq-of (s)
  (for* ((ns ()))
        ((not (member s ns)) (reverse ns))
        ((push s ns) (set s (next s)))))

(defun sort-string (s)
  [sort (copy s) >])

(tree-bind (len nums seq)
  (for-accum ((*len nil) (*nums nil) (*seq nil))
             ((n (range 1000000 0 -1))) ;; start at the high end
    (let* ((s (tostring n))
           (sorted (sort-string s)))
      (if (equal s sorted)
        (let* ((seq (seq-of s))
               (len (length seq)))
          (cond ((or (not *len) (> len *len)) (iter len (list s) seq))
                ((= len *len) (iter len (cons s *nums) seq))))
        (iter *len
              (if (and *nums (member sorted *nums)) (cons s *nums) *nums)
              *seq))))
  (put-line `Numbers: @{nums ", "}\nLength: @len`)
  (each ((n seq)) (put-line `  @n`)))

Output:

Numbers: 9009, 9090, 9900
Length: 21
  9900
  2920
  192210
  19222110
  19323110
  1923123110
  1923224110
  191413323110
  191433125110
  19151423125110
  19251413226110
  1916151413325110
  1916251423127110
  191716151413326110
  191726151423128110
  19181716151413327110
  19182716151423129110
  29181716151413328110
  19281716151423228110
  19281716151413427110
  19182716152413228110

Synchronous concurrency ↗

Using delimited-continuation-based obtain and yield-from to simulate co-routines, wrapped in some OOP. A thread base class is derived into consumer and producer, both of which provide run methods. The consumer has a counter also, and producer holds a reference to a consumer. When the objects are instantiated, their co-routines auto-start, thanks to the :postinit hook. To get things going, we resume the producer via pro.(resume), because we started that in a suspended state. This is actually not necessary; if we remove the suspended t from the new expression which instantiates the producer, we can remove this line. However, this means that the body of the let doesn't receive control. The producer finishes producing and then the pro variable is bound, and the final (put-line ...) expression evaluates. Starting the producer suspended lets us insert some logic prior to dispatching the producer. We implicitly start the consumer, though, because it immediately suspends to wait for an item, saving its context in a continuation and relinquishing control.

(defstruct thread nil
  suspended
  cont
  (:method resume (self)
    [self.cont])
  (:method give (self item)
    [self.cont item])
  (:method get (self)
    (yield-from run nil))
  (:method start (self)
    (set self.cont (obtain self.(run)))
    (unless self.suspended
      self.(resume)))
  (:postinit (self)
    self.(start)))

(defstruct consumer thread
  (count 0)
  (:method run (self)
    (whilet ((item self.(get)))
      (prinl item)
      (inc self.count))))

(defstruct producer thread
  consumer
  (:method run (self)
    (whilet ((line (get-line)))
      self.consumer.(give line))))

(let* ((con (new consumer))
       (pro (new producer suspended t consumer con)))
  pro.(resume)
  (put-line `count = @{con.count}`))

Terminal control/Positional read ↗

;;; Type definitions and constants

(typedef BOOL (enum BOOL FALSE TRUE))
(typedef HANDLE cptr)
(typedef WCHAR wchar)
(typedef DWORD uint32)
(typedef WORD uint16)
(typedef SHORT short)

(typedef COORD
         (struct COORD
           (X SHORT)
           (Y SHORT)))

(typedef SMALL_RECT
         (struct SMALL_RECT
           (Left SHORT)
           (Top SHORT)
           (Right SHORT)
           (Bottom SHORT)))

(typedef CONSOLE_SCREEN_BUFFER_INFO
         (struct CONSOLE_SCREEN_BUFFER_INFO
           (dwSize COORD)
           (dwCursorPosition COORD)
           (wAttributes WORD)
           (srWindow SMALL_RECT)
           (dwMaximumWindowSize COORD)))

;;; Various constants

(defvarl STD_INPUT_HANDLE (- #x100000000 10))
(defvarl STD_OUTPUT_HANDLE (- #x100000000 11))
(defvarl STD_ERROR_HANDLE (- #x100000000 12))

(defvarl NULL cptr-null)
(defvarl INVALID_HANDLE_VALUE (cptr-int -1))

;;; Foreign Function Bindings

(with-dyn-lib "kernel32.dll"
  (deffi GetStdHandle "GetStdHandle" HANDLE (DWORD))
  (deffi GetConsoleScreenBufferInfo "GetConsoleScreenBufferInfo"
         BOOL (HANDLE (ptr-out CONSOLE_SCREEN_BUFFER_INFO)))
  (deffi ReadConsoleOutputCharacter "ReadConsoleOutputCharacterW"
         BOOL (HANDLE (ptr-out (array 1 WCHAR))
                       DWORD COORD (ptr-out (array 1 DWORD)))))

;;; Now the character at <2, 5> -- column 3, row 6.

(let ((console-handle (GetStdHandle STD_OUTPUT_HANDLE)))
  (when (equal console-handle INVALID_HANDLE_VALUE)
    (error "couldn't get console handle"))

  (let* ((cinfo (new CONSOLE_SCREEN_BUFFER_INFO))
         (getinfo-ok (GetConsoleScreenBufferInfo console-handle cinfo))
         (coord (if getinfo-ok
                  ^#S(COORD X ,(+ 2 cinfo.srWindow.Left)
                            Y ,(+ 5 cinfo.srWindow.Top))
                  #S(COORD X 0 Y 0)))
         (chars (vector 1))
         (nread (vector 1))
         (read-ok (ReadConsoleOutputCharacter console-handle chars
                                              1 coord nread)))
    (when (eq getinfo-ok 'FALSE)
      (error "GetConsoleScreenBufferInfo failed"))
    (prinl cinfo)
    (when (eq read-ok 'FALSE)
      (error "ReadConsoleOutputCharacter failed"))
    (unless (plusp [nread 0])
      (error "ReadConsoleOutputCharacter read zero characters"))
    (format t "character is ~s\n" [chars 0])))

Notes:

An ptr-out to an array of 1 DWORD is used for the number of characters out parameter. The FFI type (ptr-out DWORD) cannot work as a function argument, because integer objects are not mutable, and there isn't any concept of taking the address of a variable. A vector of 1 integer is mutable, and by making such a vector correspond with the FFI type (array 1 DWORD), the necessary semantics is achieved.
The quasiquote expression ^#S(COORD X ,(+ 2 cinfo.srWindow.Left) Y ,(+ 5 cinfo.srWindow.Top)) is equivalent to (new COORD X (+ 2 cinfo.srWindow.Left) Y (+ 5 cinfo.srWindow.Top)). It is done this way to demonstrate support for structure quasiquoting.

Text processing/Max licenses in use ↗

Working with Version 266.


@(bind *times* #H((:eql-based) nil))
@(bind *licenses-out* 0)
@(bind *maximum-licenses-out* 0)
@(collect)
License @statuses @@ @dateTimes for job @jobNumbers
@(end)
@(do (each ((status statuses)
             (dateTime dateTimes)
             (jobNumber jobNumbers))
       (set *licenses-out*
         (if (equal status "OUT")
           (progn
             (when (>= (+ *licenses-out* 1) *maximum-licenses-out*)
               (set *maximum-licenses-out* (+ *licenses-out* 1))
               (pushhash *times* *maximum-licenses-out* dateTime))
             (+ *licenses-out* 1))
           (+ *licenses-out* -1)))))
@(output)
Maximum # of licenses out: @{*maximum-licenses-out*}
Peak time(s): @{(reverse (gethash *times* *maximum-licenses-out*))}
@(end)

Output:


Maximum # of licenses out: 99
Peak time(s): 2008/10/03_08:39:34 2008/10/03_08:40:40

Tokenize a string ↗

Collecting tokens which consist of non-empty sequences of non-commas.

@(next :list "Hello,How,Are,You,Today")
@(coll)@{token /[^,]+/}@(end)
@(output)
@(rep)@token.@(last)@token@(end)
@(end)

Different approach. Collect tokens, each of which is a piece of text which either terminates before a comma, or else extends to the end of the line.

@(next :list "Hello,How,Are,You,Today")
@(coll)@(maybe)@token,@(or)@token@(end)@(end)
@(output)
@(rep)@token.@(last)@token@(end)
@(end)

Using TXR Lisp:

txr -p '(cat-str (split-str "Hello,How,Are,You,Today" ",") ".")'
Hello.How.Are.You.Today

Top rank per group ↗

Template Output Version

This version massages the data in a way that is suitable for generating the output template-wise with an @(output) block. The data is in a file, exactly as given in the problem. Parameter N is accepted from command line.

@(next :args)
@{n-param}
@(next "top-rank-per-group.dat")
Employee Name,Employee ID,Salary,Department
@(collect :vars (record))
@name,@id,@salary,@dept
@(bind record (@(int-str salary) dept name id))
@(end)
@(bind (dept salary dept2 name id)
  @(let* ((n (int-str n-param))
          (dept-hash [group-by second record :equal-based])
          (dept (hash-keys dept-hash))
          (ranked (collect-each ((rec (hash-values dept-hash)))
                    [apply mapcar list [[sort rec > first] 0..n]])))
     (cons dept [apply mapcar list ranked])))
@(output)
@  (repeat)
Department: @dept
@    (repeat)
  @{name 15} (@id)  $@{salary -6}
@    (end)
@  (end)
@(end)

Output:

Department: D101
  George Woltman  (E00127)  $ 53500
  David McClellan (E04242)  $ 41500
  Tyler Bennett   (E10297)  $ 32000
Department: D202
  Rich Holcomb    (E01234)  $ 49500
  Claire Buckman  (E39876)  $ 27800
  David Motsinger (E27002)  $ 19250
Department: D050
  John Rappl      (E21437)  $ 47000
  Nathan Adams    (E41298)  $ 21900
Department: D190
  Kim Arlich      (E10001)  $ 57000
  Timothy Grove   (E16398)  $ 29900

Breakdown: Descend into argument list:

@(next :args)

Collect first argument as n-param variable:

@{n-param}

Drill into data file:

@(next "top-rank-per-group.dat")

Match header exactly:

Employee Name,Employee ID,Salary,Department

Now iterate over the data, requiring a variable called record to be bound in each iteration, and suppress all other variables from emerging. In the body of the collect, bind four variables. Then use these four variables to create a four-element list which is bound to the variable record. The int-str function converts the textual variable salary to an integer:

@(collect :vars (record))
@name,@id,@salary,@dept
@(bind record (@(int-str salary) dept name id))
@(end)

Next, we bind five variables to the output of some TXR Lisp code, which will return five lists:

@(bind (dept salary dept2 name id)
  @(let* ((n (int-str n-param))
          (dept-hash [group-by second record :equal-based])
          (dept (hash-keys dept-hash))
          (ranked (collect-each ((rec (hash-values dept-hash)))
                    [apply mapcar list [[sort rec > first] 0..n]])))
     (cons dept [apply mapcar list ranked])))

This code binds some successive variables. n is an integer conversion of the command line argument. dept-hash is a hash whose keys are department strings, and whose values are lists of records belonging to each respective department (the records collected previously). The hash keys are the departments; these are extracted into a variable called dept for later use. The ranked variable takes the ranking information. The salary ranking info is obtained by sorting each department's records by descending salary and then taking a 0..n slice of the list. The "apply mapcar list" is a Lisp pattern for doing a matrix transpose. We use it twice: once within the department over the list of records, and then over the list of lists of records. The reason for these transpositions is to convert the data into individual nested lists, once for each field. This is the format needed by the TXR @(output) clause:

@(output)
@  (repeat)
Department: @dept
@    (repeat)
  @{name 15} (@id)  $@{salary -6}
@    (end)
@  (end)
@(end)

Here, all these variables are individual lists. The dept variable is a flat list; one nesting of @(repeat) iterates over it. The other variables are nested lists; a nested repeat drills into these.

Lisp Output Version

In this version, the Lisp processing block performs the output, so the conversion of records into lists for the template language is omitted, simplifying the code. The output is identical to the previous version.

@(next :args)
@{n-param}
@(next "top-rank-per-group.dat")
Employee Name,Employee ID,Salary,Department
@(collect :vars (record))
@name,@id,@salary,@dept
@(bind record (@(int-str salary) dept name id))
@(end)
@(do
  (let* ((n (int-str n-param))
         (dept-hash [group-by second record :equal-based])
         (ranked (collect-each ((rec (hash-values dept-hash)))
                   [[sort rec > first] 0..n])))
    (each ((d (hash-keys dept-hash))
           (dept-recs ranked))
      (put-line `Department: @d`)
      (each ((r dept-recs))
        (put-line `  @{r[2] 15} (@{r[3]})  $@{r[0] -6}`)))))

Twelve statements ↗

(defmacro defconstraints (name size-name (var) . forms)
  ^(progn (defvar ,size-name ,(length forms))
          (defun ,name (,var)
            (list ,*forms))))

(defconstraints con con-count (s)
  (= (length s) con-count) ;; tautology
  (= (countq t [s -6..t]) 3)
  (= (countq t (mapcar (op if (evenp @1) @2) (range 1) s)) 2)
  (if [s 4] (and [s 5] [s 6]) t)
  (none [s 1..3])
  (= (countq t (mapcar (op if (oddp @1) @2) (range 1) s)) 4)
  (and (or [s 1] [s 2]) (not (and [s 1] [s 2])))
  (if [s 6] (and [s 4] [s 5]) t)
  (= (countq t [s 0..6]) 3)
  (and [s 10] [s 11])
  (= (countq t [s 6..9]) 1)
  (= (countq t [s 0..con-count]) 4))

(defun true-indices (truths)
  (mappend (do if @1 ^(,@2)) truths (range 1)))

(defvar results
  (append-each ((truths (rperm '(nil t) con-count)))
    (let* ((vals (con truths))
           (consist [mapcar eq truths vals])
           (wrong-count (countq nil consist))
           (pos-wrong (+ 1 (or (posq nil consist) -2))))
      (cond
        ((zerop wrong-count)
         ^((:----> ,*(true-indices truths))))
        ((= 1 wrong-count)
         ^((:close ,*(true-indices truths) (:wrong ,pos-wrong))))))))

(each ((r results))
  (put-line `@r`))

Output:

close 5 8 11 (wrong 1)
close 1 5 (wrong 8)
close 1 5 8 (wrong 11)
close 1 5 8 11 (wrong 12)
close 1 5 8 10 11 12 (wrong 12)
close 1 5 6 9 11 (wrong 8)
close 1 3 4 8 9 (wrong 7)
----> 1 3 4 6 7 11
close 1 3 4 6 7 9 (wrong 9)
close 1 2 4 7 9 12 (wrong 12)
close 1 2 4 7 9 10 (wrong 10)
close 1 2 4 7 8 9 (wrong 8)

Unicode strings ↗

TXR source code and I/O are all assumed to be text which is UTF-8 encoded. This is a self-contained implementation, not relying on any encoding library. TXR ignores LANG and such environment variables. One of the regression test cases uses Japanese text. Characters can be coded directly, or encoded indirectly with hexadecimal escape sequences. The regular expression engine, also an original implementation, self-contained within TXR, supports full Unicode (not only the Basic Multilingual Plane, but all planes). However, as of version 89, identifiers such as variables are restricted to English letters, numbers and underscores. Whether or not text outside of the Basic Multilingual Plane can actually be represented by a given port of TXR depends on the width of the C compiler's wchar_t type. A 16 bit wchar_t restricts the program to the BMP. Japanese test case:

@{TITLE /[あ-ん一-耙]+/} (@ROMAJI/@ENGLISH)
@(freeform)
@(coll)@{STANZA /[^\n\x3000 ]+/}@(end)@/.*/

Test data: Japanese traditional song:

春が来た (Haru-ga Kita/Spring has Come)

春が来た　春が来た　どこに来た
山に来た　里に来た　野にも来た

花が咲く　花が咲く　どこに咲く
山に咲く　里に咲く　野にも咲く

鳥がなく　鳥がなく　どこでなく
山でなく　里でなく　野でもなく

Expected output (with txr -B):

TITLE="春が来た"
ROMAJI="Haru-ga Kita"
ENGLISH="Spring has Come"
STANZA[0]="春が来た"
STANZA[1]="春が来た"
STANZA[2]="どこに来た"
STANZA[3]="山に来た"
STANZA[4]="里に来た"
STANZA[5]="野にも来た"
STANZA[6]="花が咲く"
STANZA[7]="花が咲く"
STANZA[8]="どこに咲く"
STANZA[9]="山に咲く"
STANZA[10]="里に咲く"
STANZA[11]="野にも咲く"
STANZA[12]="鳥がなく"
STANZA[13]="鳥がなく"
STANZA[14]="どこでなく"
STANZA[15]="山でなく"
STANZA[16]="里でなく"
STANZA[17]="野でもなく"

Update a configuration file ↗

This is a general solution which implements a command-line tool for updating the config file. Omitted are the trivial steps for writing the configuration back into the same file; the final result is output on standard output. The first argument is the name of the config file. The remaining arguments are of this form:

  VAR      # define or update VAR as a true-valued boolean
  VAR=     # ensure "; VAR" in the config file.
  VAR=VAL  # ensure "VAR VAL" in the config file

This works by reading the configuration into a variable, and then making multiple passes over it, using the same constructs that normally operate on files or pipes. The first 30% of the script deals with reading the configuration file and parsing each command line argument, and converting its syntax into configuration syntax, stored in new_opt_line. For each argument, the configuration is then scanned and filtered from config to new_config, using the same syntax which could be used to do the same job with temporary files. When the interesting variable is encountered in the config, using one of the applicable pattern matches, then the prepared configuration line is substituted for it. While this is going on, the encountered variable names (bindings for var_other) are also being collected into a list. This list is then later used to check via the directive @(bind opt_there option) to determine whether the option occurred in the configuration or not. The bind construct will not only check whether the left and right hand side are equal, but if nested lists are involved, it checks whether either side occurs in the other as a subtree. option binds with opt_other if it matches one of the option names in opt_other. Finally, the updated config is regurgitated.

@(next :args)
@configfile
@(maybe)
@  (next configfile)
@  (collect :vars (config))
@config
@  (end)
@(end)
@(collect)
@  (cases)
@option=
@    (output :into new_opt_line :filter :upcase)
; @option
@    (end)
@  (or)
@option=@val
@    (output :into new_opt_line :filter :upcase)
@option @val
@    (end)
@  (or)
@option
@    (output :into new_opt_line :filter :upcase)
@option
@    (end)
@  (end)
@  (next :var config)
@  (local new_config)
@  (bind new_config ())
@  (collect :vars ((opt_there "")))
@  (block)
@    (cases)
@      (cases)
@{line /[ \t]*/}
@      (or)
@{line /#.*/}
@      (end)
@      (output :append :into new_config)
@line
@      (end)
@      (accept)
@    (or)
@      (maybe)
; @opt_there
@      (or)
@opt_there @(skip)
@      (or)
@opt_there
@      (or)
@original_line
@      (end)
@    (end)
@    (cases)
@      (bind opt_there option :filter :upcase)
@      (output :append :into new_config)
@new_opt_line
@      (end)
@    (or)
@      (output :append :into new_config)
@original_line
@      (end)
@    (end)
@  (end)
@  (cases)
@    (bind opt_there option :filter :upcase)
@  (or)
@    (output :append :into new_config)
@new_opt_line
@    (end)
@  (end)
@  (set config new_config)
@(end)
@(output)
@  (repeat)
@config
@  (end)
@(end)

Sample invocation:

$ txr configfile2.txr configfile NEEDSPEELING= seedsREMOVED NUMBEROFBANANAS=1024 NUMBEROFSTRAWBERRIES=62000
# This is a configuration file in standard configuration file format
#
# Lines begininning with a hash or a semicolon are ignored by the application
# program. Blank lines are also ignored by the application program.

# The first word on each non comment line is the configuration option.
# Remaining words or numbers on the line are configuration parameter
# data fields.

# Note that configuration option names are not case sensitive. However,
# configuration parameter data is case sensitive and the lettercase must
# be preserved.

# This is a favourite fruit
FAVOURITEFRUIT banana

# This is a boolean that should be set
; NEEDSPEELING

# This boolean is commented out
SEEDSREMOVED

# How many bananas we have
NUMBEROFBANANAS 1024
NUMBEROFSTRAWBERRIES 62000

Test run on empty input:

$ echo -n | txr configfile2.txr - NEEDSPEELING= SEEDSREMOVED NUMBEROFBANANAS=1024 NUMBEROFSTRAWBERRIES=62000
; NEEDSPEELING
SEEDSREMOVED
NUMBEROFBANANAS 1024
NUMBEROFSTRAWBERRIES 62000

Test run on empty input with no arguments

$ echo -n | txr configfile2.txr -
[ no output ]

Use another language to call a function ↗

This is really two tasks: how to accept foreign callbacks, and how to link code to a C program which controls the main startup function. The TXR run-time is not available as a library that can be linked to a C program. Instead, we can put the C driver into a small library and call out to it from TXR, then accept its callback. Here is that library:

#include <stdio.h>

int query(int (*callback)(char *, size_t *))
{
  char buffer[1024];
  size_t size = sizeof buffer;

  if (callback(buffer, &size) == 0) {
    puts("query: callback failed");
  } else {
    char *ptr = buffer;

    while (size-- > 0)
      putchar (*ptr++);
    putchar('\n');
  }
}

Here are the build steps to produce a `query.so` object from it on GNU/Linux:

gcc -g -fPIC query.c -c
gcc -g --shared query.c -o query.c

Using `carray`

In this situation, the most appropriate FFI type to use for the foreign buffer is the carray type. This type allows TXR Lisp code to manipulate a foreign array while retaining its identity, so that it is able to pass the same pointer to the foreign code that it received from that code. carray also solves the problem of dealing with the common representational approach in C when arrays are represented by pointers, and do not include their size as part of their type information. A carray object can be constructed with an zero size, which can be adjusted when the size is known, using carray-set-length. Like the array type, carray has specialized behaviors when its element type is char, bchar or wchar. The carray-get function will decode a string from the underlying array, and carray-put will encode a string into the array. In the case of the char type, this involves UTF-8 coding. Callbacks are modeled as "FFI closures". The macro deffi-cb defines a function which itself isn't a callback, but is rather a combinator which converts a Lisp function into a FFI callback.

(with-dyn-lib "./query.so"
  (deffi query "query" void (closure)))

(deffi-cb query-cb int ((carray char) (ptr (array 1 size-t))))

(query (query-cb (lambda (buf sizeptr)
                   (symacrolet ((size [sizeptr 0]))
                     (let* ((s "Here am I")
                            (l (length s)))
                       (cond
                         ((> l size) 0)
                         (t (carray-set-length buf size)
                            (carray-put buf s)
                            (set size l))))))))

Output:

Here am I

Note that the obvious way of passing a size_t value by pointer, namely (ptr size-t) doesn't work. While the callback will receive the size (FFI will decode the pointer type's semantics and get the size value), updating the size will not propagate back to the caller, because it becomes, effectively, a by-value parameter. A (ptr size-t) object has to be embedded in an aggregate that is passed by reference, in order to have two-way semantics. Here we use the trick of treating the size_t * as an array of 1, which it de facto is. In the callback, we establish local symbol macro which lets us just refer to [sizeptr 0] it as size.

Using `cptr` and `memcpy`

An alternative approach is possible if we avail ourselves of the memcpy function via FFI. We can receive the data as an opaque foreign pointer represented by the cptr type. We can set up memcpy so that its destination argument and return value is a cptr, but the source argument is a string:

(with-dyn-lib "./query.so"
  (deffi query "query" void (closure))) 
 
(with-dyn-lib nil
  (deffi memcpy "memcpy" cptr (cptr str size-t))) 
 
(deffi-cb query-cb int (cptr (ptr (array 1 size-t)))) 
 
(query (query-cb (lambda (buf sizeptr)              ;  int lambda(void *buf, siz
                   (symacrolet ((size [sizeptr 0])) ;  { #define size sizeptr[0]
                     (let* ((s "Here am I")         ;    char *s = "Here am I"; 
                            (l (length s)))         ;    size_t l = strlen(s); 
                       (cond                        ;    if (length > size) 
                         ((> l size) 0)             ;    { return 0; } else 
                         (t (memcpy buf s l)        ;    { memcpy(buf, s, l); 
                            (set size l))))))))     ;      return size = l; } }

Here, the use of the str type in the memcpy interface means that FFI automatically produces a UTF-8 encoding of the string in a temporary buffer. The pointer to that temporary buffer is what is passed into memcpy. The temporary buffer is released after memcpy returns. To reveal the similarity between the Lisp logic and how a C function might be written, the corresponding C code is shown. However, that C code's semantics is, of course, devoid of any hidden UTF-8 conversion.

Exceptions from Callback

If the callback throws an exception or performs any other non-local return, it will return a default return value of all zero bits in the given return type. This value can be specified, but the zero default suits our particular situation, because the problem task defines the return value of zero as an error indicator. We can explore this interactively:

$ txr
This is the TXR Lisp interactive listener of TXR 177.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (with-dyn-lib "./query.so" (deffi query "query" void (closure)))
#:lib-0177
2> (deffi-cb query-cb int ((ptr (array 1024 char)) (ptr size-t)))
query-cb
3> (query (query-cb (lambda (x y) (error "oops"))))
query: callback failed
** oops
** during evaluation at expr-3:1 of form (error "oops")
4>

Here we can see that when the callback throws the error exception, the C code prints query: callback failed, due to receiving the default abort return value of zero. Then, the exception continues up to the interactive prompt. If a return value other than zero indicates that the callback failed, that can be arranged with an additional argument in deffi-cb:

(deffi-cb query-cb int (cptr (ptr (array 1 size-t))) -1)

Now the query-cb function generates callbacks that return -1 to the caller, rather than zero, if aborted by a non-local control transfer such as an exception.

Variable size/Get ↗

Lisp Object Size

All Lisp values are pointer-sized cells, so they have a basic size that is four or eight bytes, depending on whether the processor architecture is 32 or 64 bits. Heap values take up a four-cell record. And some objects have additional dynamically allocated memory. The prof operator can be wrapped around code which constructs and returns an object to calculate the size of the heap part plus dynamically allocated memory:

1> (prof 1)
(1 0 0 0)

The first element is the value itself; the remaining values are dynamic memory from malloc, Lisp heap memory and execution time. Here, no memory is attributed to the 1. It takes up a four byte pointer on this system, but that isn't counted.

2> (list 1 2 3)
((1 2 3) 0 48 0)

The list object requires three cons cells at 16 (4x4) bytes each.

3> (prof (copy "foobar"))
("foobar" 28 16 0)

The "foobar" string requires 28 bytes of malloc memory (7 wide characters including a terminating null). The heap entry takes 16 bytes. **Note:** the pprof macro ("pretty prof") will gather and print these values in a nice way on the *stdout* stream:

2> (pprof (copy "foobar"))
malloc bytes:            28
gc heap bytes:           16
total:                   44
milliseconds:             0
"foobar"

FFI

In the FFI type system, the sizeof macro operator reports size of types.

1> (sizeof uchar)
1
2> (sizeof (array 3 char))
3
3> (sizeof (struct foo (x (bit 17 uint32))
                       (y (bit 3 uint8))
                       (z (array 16 char))))
20
4> (sizeof double)
8
20

The struct size corresponds to the size of the C struct

struct foo {
  uint32_t x : 17;
  uint8_t y : 3;
  char z[16];
};

as calculated by the GNU C compiler on the same platform. The `uint32_t` leading bitfield creates a minimum alignment of four bytes. The `y` bitfield is packed into the third byte of the structure, and the `z` array starts on the fourth, ending on the nineteenth. The alignment requirement pads the structure to 20. We can influence the alignment with the align type constructor:

6> (sizeof (struct foo (x (align 1 (bit 17 uint32)))
                       (y (bit 3 uint8))
                       (z (array 16 char))))
19

The leading bitfield is now deemed to be byte aligned, so the structure is no longer padded for the sake of its alignment.

Variable Size

Since the task is worded as being about variables rather than objects, what we can do is explore the memory costs of a lexical environment. An empty environment takes up a 16 byte heap record:

1> (prof (let ()))
(nil 0 16 0)

Adding a variable to the environment brings in an additional 32 bytes:

2> (prof (let (a)))
(nil 0 48 0)

Variable size/Set ↗

This task has many possible interpretations in many contexts. For instance, there is a buffer type. When we create a buffer, we specify its length. Optionally, we can also specify how much storage is actually allocated. This will prevent re-allocations if the length is increased within that limit. Here, the buffer holds eight zero bytes, but 4096 bytes is allocated to it:

(make-buf 8 0 4096)

Another situation, in the context of FFI, is that some structure needs to achieve some size, but we don't care about all of its members. We can add anonymous padding to ensure that it meets the minimum size. For instance, suppose we want to call uname, and we only care about retrieving the sysname:

1> (with-dyn-lib nil
     (deffi uname "uname" int ((ptr-out (struct utsname
                                          (sysname (zarray 65 char))
                                          (nil (array 512 uint)))))))
** warning: (expr-1:2) defun: redefining uname, which is a built-in defun
#:lib-0172
2> (defvar u (new utsname))
u
3> (uname u)
0
4> u
#S(utsname sysname "Linux" nodename nil release nil version nil machine nil
           domainname nil)

We have specified a FFI definition for utsname which lays down the sysname member to the correct system-specific array size, and then a generous amount of padding: 512 unsigned integers. Anonymous padding can be specified anywhere in a FFI structure by using the slot name nil. The corresponding space will be reserved in the structure using the type of that slot, but the slot will not participate in any data conversions. FFI will not fill in that area of the structure when preparing data, and will not extract anything from that area in the reverse direction. The padding prevents the uname function from accessing beyond the end of the memory that is passed to it. We can, of course, determine the exact size of struct utsname we can specify the padding such that we know for certain that it meets or exceeds the requirement.

Variable-length quantity ↗

TXR's carray type, closely associated with the Foreign Function Interface, has functions for converting between integers and foreign arrays. The arrays can use any element type. The integer is stored in big endian order, and "right justified" within the buffer, so that its least significant byte is aligned with the least significant byte of the last element of the array. Two representations are supported: unsigned and signed. The unsigned representation takes only non-negative integers. It is a straightforward pure binary enumeration. The signed representation uses twos complement. The most significant byte of the array representation is in the range 80-FF if the value is negative, otherwise in the range 0 to 7F. This means that in some cases, a zero byte has to be added. Interactive session:

1> (carray-num #x200000)
#<carray 3 #<ffi-type uchar>>
2> (carray-get *1)
#(32 0 0)
3> (carray-num #x1FFFFF)
#<carray 3 #<ffi-type uchar>>
4> (carray-get *3)
#(31 255 255)
5> (num-carray *1)
2097152
6> (num-carray *3)
2097151

Conversion to a carray not based on the default uchar:

1> (carray-num #x123456789 (ffi uint32))
#<carray 2 #<ffi-type uint32>>
2> (carray-get *1)
#(16777216 2305246499)

This number requires two 32-bit units to store. Because uint32 is in the native endian, opposite to the big endian storage of the integer, the words come out byte swapped. The be-uint32 type could be used to change this.

Variables ↗

Variables have a form of pervasive dynamic scope in TXR. Each statement ("directive") of the query inherits the binding environment of the previous, invoking, or surrounding directive, as the case may be. The initial contents of the binding environment may be initialized on the interpreter's command line. The environment isn't simply a global dictionary. Each directive which modifies the environment creates a new version of the environment. When a subquery fails and TXR backtracks to some earlier directive, the original binding environment of that directive is restored, and the binding environment versions generated by backtracked portions of the query turn to garbage. Simple example: the cases

@(cases)
hey @a
how are you
@(or)
hey @b
long time no see
@(end)

This directive has two clauses, matching two possible input cases, which have a common first line. The semantics of cases is short-circuiting: the first successful clause causes it to succeed and stop processing subsequent clauses. Suppose that the input matches the second clause. This means that the first clause will also match the first line, thereby establishing a binding for the variable a. However, the first clause fails to match on the second line, which means that it fails. The interpreter then moves to the second clause, which is tried at the original input position, under the original binding environment which is devoid of the a variable. Whichever clause of the cases is successful will pass both its environment modifications and input position increment to the next element of the query. Under some other constructs, environments may be merged:

@(maybe)
@a bar
@(or)
foo @b
@(end)

The maybe directive matches multiple clauses such that it succeeds no matter what, even if none of the clauses succeed. Clauses which fail have no effect, but the effects of all successful clauses are merged. This means that if the input which faces the above maybe is the line "foo bar", the first clause will match and bind a to foo, and the second clause will also match and bind b to bar. The interpreter integrates these results together and the environment which emerges has both bindings.

Vigenère cipher ↗

@(next :args)
@(do
   (defun vig-op (plus-or-minus)
     (op + #\A [mod [plus-or-minus (- @1 #\A) (- @2 #\A)] 26]))

   (defun vig (msg key encrypt)
     (mapcar (vig-op [if encrypt + -]) msg (repeat key))))
@(coll)@{key /[A-Za-z]/}@(end)
@(coll)@{msg /[A-Za-z]/}@(end)
@(cat key "")
@(filter :upcase key)
@(cat msg "")
@(filter :upcase msg)
@(bind encoded @(vig msg key t))
@(bind decoded @(vig msg key nil))
@(bind check @(vig encoded key nil))
@(output)
text:  @msg
key:   @key
enc:   @encoded
dec:   @decoded
check: @check
@(end)

Here, the TXR pattern language is used to scan letters out of two arguments, and convert them to upper case. The embedded TXR Lisp dialect handles the Vigenère logic, in just a few lines of code. Lisp programmers may do a "double take" at what is going on here: yes mapcar can operate on strings and return strings in TXR Lisp. (repeat key) produces an infinite lazy list; but that's okay because mapcar stops after the shortest input runs out of items. Run:

$ txr vigenere.txr 'vigenere cipher' 'Beware the Jabberwock... The jaws that... the claws that catch!'
text:  BEWARETHEJABBERWOCKTHEJAWSTHATTHECLAWSTHATCATCH
key:   VIGENERECIPHER
enc:   WMCEEIKLGRPIFVMEUGXXYILILZXYVBZLRGCEYAIOEKXIZGU
dec:   GWQWEACDCBLUXNWOIYXPQAHSHLPQFLNDRYUWUKEAWCHSNYU
check: BEWARETHEJABBERWOCKTHEJAWSTHATTHECLAWSTHATCATCH

Walk a directory/Non-recursively ↗

Using `glob`

(glob "/etc/*.conf")

Output:

("/etc/adduser.conf" "/etc/apg.conf" "/etc/blkid.conf" "/etc/brltty.conf"
 "/etc/ca-certificates.conf" "/etc/colord.conf" "/etc/ddclient.conf"
 "/etc/debconf.conf" "/etc/deluser.conf" "/etc/dnsmasq.conf" "/etc/ffserver.conf"
 "/etc/fuse.conf" "/etc/gai.conf" "/etc/hdparm.conf" "/etc/host.conf"
 "/etc/insserv.conf" "/etc/irssi.conf" "/etc/kernel-img.conf"
 "/etc/kerneloops.conf" "/etc/knockd.conf" "/etc/ld.so.conf" "/etc/lftp.conf"
 "/etc/logrotate.conf" "/etc/ltrace.conf" "/etc/mke2fs.conf" "/etc/mtools.conf"
 "/etc/netscsid.conf" "/etc/nsswitch.conf" "/etc/ntp.conf" "/etc/pam.conf"
 "/etc/pnm2ppa.conf" "/etc/popularity-contest.conf" "/etc/resolv.conf"
 "/etc/rsyslog.conf" "/etc/sensors3.conf" "/etc/sysctl.conf" "/etc/ucf.conf"
 "/etc/updatedb.conf" "/etc/usb_modeswitch.conf" "/etc/wodim.conf")

Using `open-directory` and `get-lines`

(mappend [iff (op ends-with ".conf") list] (get-lines (open-directory "/etc")))

Output:

("ddclient.conf" "gai.conf" "ucf.conf" "kernel-img.conf" "ltrace.conf"
 "debconf.conf" "apg.conf" "adduser.conf" "mke2fs.conf" "colord.conf"
 "kerneloops.conf" "fuse.conf" "hdparm.conf" "irssi.conf" "host.conf"
 "ffserver.conf" "pam.conf" "sysctl.conf" "ld.so.conf" "dnsmasq.conf"
 "insserv.conf" "brltty.conf" "deluser.conf" "netscsid.conf" "nsswitch.conf"
 "mtools.conf" "wodim.conf" "updatedb.conf" "popularity-contest.conf"
 "knockd.conf" "ntp.conf" "sensors3.conf" "resolv.conf" "blkid.conf"
 "lftp.conf" "ca-certificates.conf" "usb_modeswitch.conf" "logrotate.conf"
 "rsyslog.conf" "pnm2ppa.conf")

Walk a directory/Recursively ↗

There is more than one way to do this in TXR. A recursive walk could be coded using open-directory and getline. Or FFI could be used to gain access to some platform-specific functions like Microsoft's FindFirstFile and so forth.

Using `ftw`

TXR wraps and exposes the POSIX nftw function, which is demonstrated here. This function encapsulates a tree walk, and uses callbacks to inform the program of visited filesystem tree nodes, and of error situations. We can use a lambda for the code walk, or wrap the invocation of ftw with a macro which hides the lambda syntax. Here we use the build macro for procedural list building to gather all of the found paths into a list, which is implicitly returned. The callback is an explicit lambda:

(build (ftw "." (lambda (path type stat level base)
                  (if (ends-with ".tl" path)
                    (add path)))))

Output:

("./tests/016/arith.tl" "./tests/014/dgram-stream.tl" "./tests/014/socket-basic.tl"
 "./tests/sock-common.tl" "./tests/012/ifa.tl" "./tests/012/except.tl"
 "./tests/012/fini.tl" "./tests/012/oop.tl" "./tests/012/circ.tl"
 "./tests/012/cont.tl" "./tests/012/aseq.tl" "./tests/012/quasi.tl"
 "./tests/012/struct.tl" "./tests/012/man-or-boy.tl" "./tests/017/glob-carray.tl"
 "./tests/017/glob-zarray.tl" "./tests/017/realpath.tl" "./tests/017/qsort.tl"
 "./tests/015/split.tl" "./tests/013/maze.tl" "./tests/common.tl"
 "./tests/011/special-1.tl" "./share/txr/stdlib/ifa.tl" "./share/txr/stdlib/with-stream.tl"
 "./share/txr/stdlib/pmac.tl" "./share/txr/stdlib/except.tl" "./share/txr/stdlib/awk.tl"
 "./share/txr/stdlib/package.tl" "./share/txr/stdlib/place.tl"
 "./share/txr/stdlib/trace.tl" "./share/txr/stdlib/type.tl" "./share/txr/stdlib/keyparams.tl"
 "./share/txr/stdlib/ffi.tl" "./share/txr/stdlib/ver.tl" "./share/txr/stdlib/build.tl"
 "./share/txr/stdlib/cadr.tl" "./share/txr/stdlib/hash.tl" "./share/txr/stdlib/error.tl"
 "./share/txr/stdlib/txr-case.tl" "./share/txr/stdlib/tagbody.tl"
 "./share/txr/stdlib/getopts.tl" "./share/txr/stdlib/socket.tl"
 "./share/txr/stdlib/struct.tl" "./share/txr/stdlib/getput.tl"
 "./share/txr/stdlib/path-test.tl" "./share/txr/stdlib/with-resources.tl"
 "./share/txr/stdlib/yield.tl" "./share/txr/stdlib/conv.tl" "./share/txr/stdlib/termios.tl")

For a regex pattern we can replace (endswith ".tl" path) with something like (m$ path #/\.tl/). TXR also provides the fnmatch function which can be used to match using a file globbing pattern.

1< (fnmatch "*.tl" "foo.tl")
t
2>< (fnmatch "*.tl" "foo.c")
nil

The type, stat, level and base callback arguments we are ignoring closely follow those of the POSIX C nftw function. type is a type code which indicates the kind of item visited: file, directory; stat is a Lisp version of struct stat, providing various information about the filesystem object: permissions, timestamps, inode number, etc. A nice approach would be to capture a continuation in the callback, and then obtain the walk elements lazily; alas, capturing a continuation from a C library function's callback is not permitted, because the capture would span foreign stack frames.

Using `glob*`

TXR has a glob* function which, like glob is built on the POSIX C library function. glob* also provides Bash-style brace expansion, as well as the double star pattern, which we can use to find files recursively:

(glob* "**/*.c")

Output:

("args.c" "arith.c" "autoload.c" "buf.c" "cadr.c" "chksum.c" "chksums/crc32.c"
 "chksums/md5.c" "chksums/sha1.c" "chksums/sha256.c" "combi.c"
 "debug.c" "eval.c" "ffi.c" "filter.c" "ftw.c" "gc.c" "glob.c"
 "gzio.c" "hash.c" "itypes.c" "lib.c" "linenoise/example.c" "linenoise/linenoise.c"
 "match.c" "mpi/mpi.c" "mpi/mplogic.c" "parser.c" "protsym.c"
 "psquare.c" "rand.c" "regex.c" "signal.c" "socket.c" "stream.c"
 "struct.c" "strudel.c" "sysif.c" "syslog.c" "termios.c" "time.c"
 "tree.c" "txr.c" "unwind.c" "utf8.c" "vm.c")

Web scraping ↗

Robust

Large amounts of the document are matched (in fact the entire thing!), rather than blindly looking for some small amount of context. If the web page changes too much, the query will fail to match. TXR will print the word "false" and terminate with a failed exit status. This is preferrable to finding a false positive match and printing a wrong result. (E.g. any random garbage that happened to be in a line of HTML accidentally containing the string UTC).

@(next @(open-command "wget -c http://tycho.usno.navy.mil/cgi-bin/timer.pl -O - 2> /dev/null"))
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final"//EN>
<html>
<body>
<TITLE>What time is it?</TITLE>
<H2> US Naval Observatory Master Clock Time</H2> <H3><PRE>
@(collect :vars (MO DD HH MM SS (PM "  ") TZ TZNAME))
<BR>@MO. @DD, @HH:@MM:@SS @(maybe)@{PM /PM/} @(end)@TZ@/\t+/@TZNAME
@  (until)
</PRE>@/.*/
@(end)
</PRE></H3><P><A HREF="http://www.usno.navy.mil"> US Naval Observatory</A>

</body></html>
@(output)
@  (repeat)
@MO-@DD @HH:@MM:@SS @PM @TZ
@  (end)
@(end)

Sample run:

$ txr navytime.txr 
Nov-22 22:49:41    UTC
Nov-22 05:49:41 PM EST
Nov-22 04:49:41 PM CST
Nov-22 03:49:41 PM MST
Nov-22 02:49:41 PM PST
Nov-22 01:49:41 PM AKST
Nov-22 12:49:41 PM HAST

Get just the UTC time:

$ txr -DTZ=UTC navytime.txr 
Nov-22 22:50:16    UTC

Naive

Skip stuff until a line beginning with <BR> has some stuff before "UTC", and capture that stuff:

@(next @(open-command "wget -c http://tycho.usno.navy.mil/cgi-bin/timer.pl -O - 2> /dev/null"))
@(skip)
<BR>@time@\ UTC@(skip)
@(output)
@time
@(end)

Window creation ↗

TXR has no library module for connecting to SDL, X11's Xlib, or GTK2. All of these examples are completely self-contained, using the FFI capability in TXR, which can bind to any library whose interface is defined in terms of C functions and types. No C header file is processed, and not a single line of C has to be compiled.

SDL

Translation of C

A wait for a SDL key-up event is added, missing in the C version, so that the window does not just appear and disappear. Note that SDL's header file uses a enum for the event constants like SDL_KEYUP. But then in union SD_Event, the event field declared as UInt8. (That's how it appears on my Ubuntu system; newer versions of SDL seems to have switched the type field, and other fields of the event structures, to UInt32.) Here, we exploit TXR's capability to define enumerations of specific types: we make the event enumeration based on uint8, giving it a typedef name, and then use that typedef in the SD_Event union.

(defvarl SDL_INIT_VIDEO #x00000020)
(defvarl SDL_SWSURFACE #x00000000)
(defvarl SDL_HWPALETTE #x20000000)

(typedef SDL_Surface (cptr SDL_Surface))

(typedef SDL_EventType (enumed uint8 SDL_EventType
                          (SDL_KEYUP 3)
                          (SDL_QUIT 12)))

(typedef SDL_Event (union SD_Event
                     (type SDL_EventType)
                     (pad (array 8 uint32))))


(with-dyn-lib "libSDL.so"
  (deffi SDL_Init "SDL_Init" int (uint32))
  (deffi SDL_SetVideoMode "SDL_SetVideoMode"
    SDL_Surface (int int int uint32))
  (deffi SDL_GetError "SDL_GetError" str ())
  (deffi SDL_WaitEvent "SDL_WaitEvent" int ((ptr-out SDL_Event)))
  (deffi SDL_Quit "SDL_Quit" void ()))

(when (neql 0 (SDL_Init SDL_INIT_VIDEO))
  (put-string `unable to initialize SDL: @(SDL_GetError)`)
  (exit nil))

(unwind-protect
  (progn
    (SDL_SetVideoMode 800 600 16 (logior SDL_SWSURFACE SDL_HWPALETTE))
    (let ((e (make-union (ffi SDL_Event))))
      (until* (memql (union-get e 'type) '(SDL_KEYUP SDL_QUIT))
        (SDL_WaitEvent e))))
  (SDL_Quit))

X11

Translation of C

One difference between the C original and this one is that the XLib macros for direct structure access, like DefaultGC, DefaultScreen or WhitePixel are not used; rather the correspoding C functions are used via FFI: XDefaultScreen and so on. The macro approach can be mimiced in detail, at the cost of a significant increase in verbosity (cloning the full declaration of the _XDisplay struct declaration, and reproducing the macros). Also, this uses an enumeration for the events, so when the event type is decoded from the XEvent union, it comes out as a Lisp symbol.

(typedef XID uint32)

(typedef Window XID)

(typedef Drawable XID)

(typedef Display (cptr Display))

(typedef GC (cptr GC))

(typedef XEventType (enum _XEventType
                      (KeyPress 2)
                      (Expose 12)))

(defvarl KeyPressMask (ash 1 0))
(defvarl ExposureMask (ash 1 15))

(typedef XEvent (union _XEvent
                  (type XEventType)
                  (pad (array 24 long))))

(defvarl NULL cptr-null)

(with-dyn-lib "libX11.so"
  (deffi XOpenDisplay "XOpenDisplay" Display (bstr))
  (deffi XCloseDisplay "XCloseDisplay" int (Display))
  (deffi XDefaultScreen "XDefaultScreen"  int (Display))
  (deffi XRootWindow "XRootWindow" Window (Display int))
  (deffi XBlackPixel "XBlackPixel" ulong (Display int))
  (deffi XWhitePixel "XWhitePixel" ulong (Display int))
  (deffi XCreateSimpleWindow "XCreateSimpleWindow" Window (Display
                                                           Window
                                                           int int
                                                           uint uint uint
                                                           ulong ulong))
  (deffi XSelectInput "XSelectInput" int (Display Window long))
  (deffi XMapWindow "XMapWindow" int (Display Window))
  (deffi XNextEvent "XNextEvent" int (Display (ptr-out XEvent)))
  (deffi XDefaultGC "XDefaultGC" GC (Display int))
  (deffi XFillRectangle "XFillRectangle" int (Display Drawable GC
                                              int int uint uint))
  (deffi XDrawString "XDrawString" int (Display Drawable GC
                                        int int bstr int)))

(let* ((msg "Hello, world!")
       (d (XOpenDisplay nil)))
  (when (equal d NULL)
    (put-line "Cannot-open-display" *stderr*)
    (exit 1))

  (let* ((s (XDefaultScreen d))
         (w (XCreateSimpleWindow d (XRootWindow d s) 10 10 100 100 1
                                 (XBlackPixel d s) (XWhitePixel d s))))
    (XSelectInput d w (logior ExposureMask KeyPressMask))
    (XMapWindow d w)

    (while t
      (let ((e (make-union (ffi XEvent))))
        (XNextEvent d e)
        (caseq (union-get e 'type)
          (Expose
            (XFillRectangle d w (XDefaultGC d s) 20 20 10 10)
            (XDrawString d w (XDefaultGC d s) 10 50 msg (length msg)))
          (KeyPress (return)))))

    (XCloseDisplay d)))

GTK2

Translation of C

(typedef GtkObject* (cptr GtkObject))
(typedef GtkWidget* (cptr GtkWidget))

(typedef GtkWidget* (cptr GtkWidget))

(typedef GtkWindowType (enum GtkWindowType
                         GTK_WINDOW_TOPLEVEL
                         GTK_WINDOW_POPUP))

(with-dyn-lib "libgtk-x11-2.0.so.0"
  (deffi gtk_init "gtk_init" void ((ptr int) (ptr (ptr (zarray str)))))
  (deffi gtk_window_new "gtk_window_new" GtkWidget* (GtkWindowType))
  (deffi gtk_signal_connect_full "gtk_signal_connect_full"
    ulong (GtkObject* str closure closure val closure int int))
  (deffi gtk_widget_show "gtk_widget_show" void (GtkWidget*))
  (deffi gtk_main "gtk_main" void ())
  (deffi-sym gtk_main_quit "gtk_main_quit"))

(defmacro GTK_OBJECT (cptr)
  ^(cptr-cast 'GtkObject ,cptr))

(defmacro gtk_signal_connect (object name func func-data)
  ^(gtk_signal_connect_full ,object ,name ,func cptr-null
                            ,func-data cptr-null 0 0))

(gtk_init (length *args*) (vec-list *args*))

(let ((window (gtk_window_new 'GTK_WINDOW_TOPLEVEL)))
  (gtk_signal_connect (GTK_OBJECT window) "destroy" gtk_main_quit nil)
  (gtk_widget_show window)
  (gtk_main))

Win32/Win64

This solution is based on the "Your First Windows Program" example in MSDN. It registers a Window class, creates a Window and runs a Windows message loop against a custom WndProc function that is written in Lisp, which handles WM_QUIT and WM_PAINT events exactly like its C counterpart. All necessary basic types, structures, constants and foreign functions are declared using the TXR FFI language. Note that the CW_USEDEFAULT constant in the Windows header files is defined as 0x80000000. This is out of range of the signed int arguments of CreateWindowEx with which it is used. Microsoft is relying on an implementation-defined C conversion to turn this value into the most negative int. When the original constant was used in the TXR translation, TXR's FFI uncovered this little problem by throwing an exception arising from the out-of-range conversion attempt. The fix is to specify the correct value directly as #x-80000000.

(typedef LRESULT int-ptr-t)
(typedef LPARAM int-ptr-t)
(typedef WPARAM uint-ptr-t)

(typedef UINT uint32)
(typedef LONG int32)
(typedef WORD uint16)
(typedef DWORD uint32)
(typedef LPVOID cptr)
(typedef BOOL (bool int32))
(typedef BYTE uint8)

(typedef HWND (cptr HWND))
(typedef HINSTANCE (cptr HINSTANCE))
(typedef HICON (cptr HICON))
(typedef HCURSOR (cptr HCURSOR))
(typedef HBRUSH (cptr HBRUSH))
(typedef HMENU (cptr HMENU))
(typedef HDC (cptr HDC))

(typedef ATOM WORD)
(typedef LPCTSTR wstr)

(defvarl NULL cptr-null)

(typedef WNDCLASS (struct WNDCLASS
                    (style UINT)
                    (lpfnWndProc closure)
                    (cbClsExtra int)
                    (cbWndExtra int)
                    (hInstance HINSTANCE)
                    (hIcon HICON)
                    (hCursor HCURSOR)
                    (hbrBackground HBRUSH)
                    (lpszMenuName LPCTSTR)
                    (lpszClassName LPCTSTR)))

(defmeth WNDCLASS :init (me)
  (zero-fill (ffi WNDCLASS) me))

(typedef POINT (struct POINT
                 (x LONG)
                 (y LONG)))

(typedef MSG (struct MSG
               (hwnd HWND)
               (message UINT)
               (wParam WPARAM)
               (lParam LPARAM)
               (time DWORD)
               (pt POINT)))

(typedef RECT (struct RECT
                (left LONG)
                (top LONG)
                (right LONG)
                (bottom LONG)))

(typedef PAINTSTRUCT (struct PAINTSTRUCT
                       (hdc HDC)
                       (fErase BOOL)
                       (rcPaint RECT)
                       (fRestore BOOL)
                       (fIncUpdate BOOL)
                       (rgbReserved (array 32 BYTE))))

(defvarl CW_USEDEFAULT #x-80000000)
(defvarl WS_OVERLAPPEDWINDOW #x00cf0000)

(defvarl SW_SHOWDEFAULT 5)

(defvarl WM_DESTROY 2)
(defvarl WM_PAINT 15)

(defvarl COLOR_WINDOW 5)

(deffi-cb wndproc-fn LRESULT (HWND UINT LPARAM WPARAM))

(with-dyn-lib "kernel32.dll"
  (deffi GetModuleHandle "GetModuleHandleW" HINSTANCE (wstr)))

(with-dyn-lib "user32.dll"
  (deffi RegisterClass "RegisterClassW" ATOM ((ptr-in WNDCLASS)))
  (deffi CreateWindowEx "CreateWindowExW" HWND (DWORD
                                               LPCTSTR LPCTSTR
                                               DWORD
                                               int int int int
                                               HWND HMENU HINSTANCE
                                               LPVOID))
  (deffi ShowWindow "ShowWindow" BOOL (HWND int))
  (deffi GetMessage "GetMessageW"  BOOL ((ptr-out MSG) HWND UINT UINT))
  (deffi TranslateMessage "TranslateMessage"  BOOL ((ptr-in MSG)))
  (deffi DispatchMessage "DispatchMessageW"  LRESULT ((ptr-in MSG)))
  (deffi PostQuitMessage "PostQuitMessage" void (int))
  (deffi DefWindowProc "DefWindowProcW" LRESULT (HWND UINT LPARAM WPARAM))
  (deffi BeginPaint "BeginPaint" HDC (HWND (ptr-out PAINTSTRUCT)))
  (deffi EndPaint "EndPaint" BOOL (HWND (ptr-in PAINTSTRUCT)))
  (deffi FillRect "FillRect" int (HDC (ptr-in RECT) HBRUSH)))

(defun WindowProc (hwnd uMsg wParam lParam)
  (caseql* uMsg
    (WM_DESTROY
      (PostQuitMessage 0)
      0)
    (WM_PAINT
      (let* ((ps (new PAINTSTRUCT))
             (hdc (BeginPaint hwnd ps)))
        (FillRect hdc ps.rcPaint (cptr-int (succ COLOR_WINDOW) 'HBRUSH))
        (EndPaint hwnd ps)
        0))
    (t (DefWindowProc hwnd uMsg wParam lParam))))

(let* ((hInstance (GetModuleHandle nil))
       (wc (new WNDCLASS
                lpfnWndProc [wndproc-fn WindowProc]
                hInstance hInstance
                lpszClassName "Sample Window Class")))
  (RegisterClass wc)
  (let ((hwnd (CreateWindowEx 0 wc.lpszClassName "Learn to Program Windows"
                              WS_OVERLAPPEDWINDOW
                              CW_USEDEFAULT CW_USEDEFAULT
                              CW_USEDEFAULT CW_USEDEFAULT
                              NULL NULL hInstance NULL)))
    (unless (equal hwnd NULL)
      (ShowWindow hwnd SW_SHOWDEFAULT)

      (let ((msg (new MSG)))
        (while (GetMessage msg NULL 0 0)
          (TranslateMessage msg)
          (DispatchMessage msg))))))

Window creation/X11 ↗

See Window_creation#TXR .

XML/Input ↗

This program shows how most of the information in the XML can be extracted with very little code, which doesn't actually understand XML. The name Émily is properly converted from the HTML/XML escape syntax.

<Students>
@(collect :vars (NAME GENDER YEAR MONTH DAY (PET_TYPE "none") (PET_NAME "")))
@  (cases)
  <Student Name="@NAME" Gender="@GENDER" DateOfBirth="@YEAR-@MONTH-@DAY"@(skip)
@  (or)
  <Student DateOfBirth="@YEAR-@MONTH-@DAY" Gender="@GENDER" Name="@NAME"@(skip)
@  (end)
@  (maybe)
    <Pet Type="@PET_TYPE" Name="@PET_NAME" />
@  (end)
@(until)
</Students>
@(end)
@(output :filter :from_html)
NAME         G DOB        PET
@  (repeat)
@{NAME 12} @GENDER @YEAR-@MONTH-@DAY @PET_TYPE @PET_NAME
@  (end)
@(end)

Sample run:

$ txr students.txr students.xml
NAME         G DOB        PET
April        F 1989-01-02 none 
Bob          M 1990-03-04 none 
Chad         M 1991-05-06 none 
Dave         M 1992-07-08 dog Rover
Émily        F 1993-09-10 none

To obtain the output specified in this task, we can simply reduce the @(output) block to this:

@(output :filter :from_html)
@NAME
@(end)


April
Bob
Chad
Dave
Émily

Y combinator ↗

This prints out 24, the factorial of 4:

;; The Y combinator:
(defun y (f)
  [(op @1 @1)
   (op f (op [@@1 @@1]))])

;; The Y-combinator-based factorial:
(defun fac (f)
  (do if (zerop @1)
         1
         (* @1 [f (- @1 1)])))

;; Test:
(format t "~s\n" [[y fac] 4])

Both the op and do operators are a syntactic sugar for currying, in two different flavors. The forms within do that are symbols are evaluated in the normal Lisp-2 style and the first symbol can be an operator. Under op, any forms that are symbols are evaluated in the Lisp-2 style, and the first form is expected to evaluate to a function. The name do stems from the fact that the operator is used for currying over special forms like if in the above example, where there is evaluation control. Operators can have side effects: they can "do" something. Consider (do set a @1) which yields a function of one argument which assigns that argument to a. The compounded @@... notation allows for inner functions to refer to outer parameters, when the notation is nested. Consider

(op foo @1 (op bar @2 @@2))

. Here the @2 refers to the second argument of the anonymous function denoted by the inner op. The @@2 refers to the second argument of the outer op.

Yahoo! search interface ↗

The following gives us a shell utility which we can invoke with arguments like "rosetta 0" to get the first page of search results for "rosetta". The two arguments are handled as if they were two lines of text from a data source using @(next :args). We throw an exception if there is no match (insufficient arguments are supplied). The @(cases) directive has strictly ordered evaluation, so the throw in the second branch does not happen if the first branch has a successful pattern match. If the similar @(maybe) or @(some) directives were used, this wouldn't work. A little sprinkling of regex is used.

#!/usr/bin/txr -f
@(next :args)
@(cases)
@  QUERY
@  PAGE
@(or)
@  (throw error "specify query and page# (from zero)")
@(end)
@(next (open-command "!wget -O - http://search.yahoo.com/search?p=@QUERY\&b=@{PAGE}1 2> /dev/null"))
@(all)
@  (coll)<a class="yschttl spt" href="@URL" @/[^>]+/>@TITLE</a>@(end)
@(and)
@  (coll)<div class="@/abstr|sm-abs/">@ABSTR</div>@(end)
@(end)
@(output)
@  (repeat)
TITLE: @TITLE
URL: @URL
TEXT: @ABSTR
---
@  (end)
@(end)

Sample run:

$ ./yahoosearch.txr rosetta 0
TITLE: <b>Rosetta</b> | Partner With Our Interactive <wbr />Marketing Agency Today
URL: http://www.rosetta.com/Pages/default.aspx
TEXT: Learn about the fastest growing interactive marketing agency in the country - <b>Rosetta</b>. Our strategic marketing planning is custom built and connects you with your ...
---
TITLE: Official <b>Rosetta</b> StoneÂ® - Learn a <wbr />Language Online - Language ...
URL: http://www.rosettastone.com/
TEXT: <b>Rosetta</b> Stone is the world&#39;s #1 language-learning software. Our comprehensive foreign language program provides language learning for individuals and language learning ...
---
TITLE: <b>Rosetta</b> (software) - Wikipedia, the <wbr />free encyclopedia
URL: http://en.wikipedia.org/wiki/Rosetta_(software)
TEXT: Rosettais a lightweight dynamic translatorfor Mac OS Xdistributed by Apple. It enabled applications compiled for the PowerPCfamily of processors to run on Apple systems that use...
---
TITLE: <b>Rosetta</b> (spacecraft) - Wikipedia, the <wbr />free encyclopedia
URL: http://en.wikipedia.org/wiki/Rosetta_space_probe
TEXT: Rosettais a robotic spacecraftof the European Space Agencyon a mission to study the comet 67P/ChuryumovâGerasimenko. <b>Rosetta </b>consists of two main elements: the <b>Rosetta </b>space probeand...
---
TITLE: Apple - Mac
URL: http://www.apple.com/mac/
TEXT: Discover the world of Mac. Check out MacBook, iMac, iLife, and more. Download QuickTime, Safari, and widgets for free.
---
TITLE: <b>Rosetta</b> | Free Music, Tour Dates, <wbr />Photos, Videos
URL: http://www.myspace.com/rosetta
TEXT:  <b>Rosetta</b>&#39;s official profile including the latest music, albums, songs, music videos and more updates.
---
TITLE: <b>Rosetta</b>
URL: http://rosettaband.com/
TEXT: Metal for astronauts. Philadelphia, since 2003. Contact us at rosettaband@gmail.com Twitter | Facebook
---
TITLE: <b>Rosetta</b>
URL: http://rosetta.jpl.nasa.gov/
TEXT: The <b>Rosetta</b> spacecraft is on its way to catch and land a robot on a comet! <b>Rosetta</b> will reach comet &#39;67P/Churyumov-Gerasimenko&#39; (&#39;C-G&#39;) in 2014. The European Space Agency ...
---
TITLE: <b>Rosetta</b> : Multi-script Typography
URL: http://rosettatype.com/
TEXT: <b>Rosetta</b> is a new independent foundry with a strong focus on multi-script typography. We are committed to promote research and knowledge in that area and to support ...
---
TITLE: <b>Rosetta</b> (1999) - IMDb
URL: http://www.imdb.com/title/tt0200071/
TEXT: With Ãmilie Dequenne, Fabrizio Rongione, Anne Yernaux, Olivier Gourmet. Young and impulsive <b>Rosetta</b> lives with her alcoholic mother and, moved by despair, she will ...
---

Verbose

Run:

Sugared

Output:

Yield-based

Output:

OOP-based

Translation of Scheme

Output:

Delimited Continuations

Output:

Pattern Language

Run:

Translation of Common_Lisp

Output:

Output:

Literals

Construction

Array Indexing Notation

Array Range Notation

In The Pattern Language

Other Kinds of Objects

Run:

Output:

Output:

Call uname on Linux

Output:

Output:

Output:

Sugared

Output:

Desugared

Translation of Emacs Lisp

Delimited Continuations

Run:

Output:

Output:

Output:

Macro wrapper for defstruct

Output:

Custom defstruct clause

Output:

Standard Library

Output:

FFI access to Zlib

Output:

Lisp Code

Output:

Simple

With Styling

Output:

Microsoft Windows

Pattern Matching

TXR Lisp

Run:

Translation of CommonLisp

Built-in

Functional

Output:

Translation of Racket

Output:

Output:

80 Column Task

Forth Blocks Task

Encoding

Output:

Decoding

Output:

Output:

Taylor Series

Translation of Ada

Output:

Stirling

Output:

Lanczos

Translation of Haskell

Output:

Naive macro

Using placelet

Using place expanders

Call `uname` on Linux

Macro wrapper for `defstruct`

Custom `defstruct` clause

Using `placelet`