100 doors

@(do (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")`)))

99 Bottles of Beer

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

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

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

   (exit 0))

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

Slick

@(do (let ((f (let ((sum 0)) (do inc sum @1))))
       (mapdo (op format t "~s -> ~s\n" @1 [f @1]) (gun (read)))))

Output:

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

Ackermann function

Translation of Scheme

with memoization.
@(do
   (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

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

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
Code:
@(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

@(do
   (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


@(do (defvar *h* (make-hash nil nil nil))
     (each ((k '(a b c))
            (v '(1 2 3)))
       (set [*h* k nil] v))
     (dohash (k v *h*)
       (format t "~a -> ~a\n" k v))))

$ txr hash.txr 
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 shuffle (list)
       (for* ((vec (vector-list list))
              (len (length vec))
              (i 0))
             ((< i len) (list-vector vec))
             ((inc i))
         (let ((j (random r len))
               (temp [vec i]))
           (set [vec i] [vec j])
           (set [vec j] temp))))

     (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
][[[]][][[]]                    ][[[]][][[]]   
[]][[]][][[]    []              ][[]][][[]     
[][[[[]]]]][    []              [[[[]]]]][     
][[][[]]][][                    ][[][[]]][][   
[[[][[]]][]]    [[[][[]]][]]                   
]][]][[[][[]                    ]][]][[[][[]   
[[]][]][[[]]    [[]]            []][[[]]       
]][]][]][[[[                    ]][]][]][[[[   
]][[]]][][[[                    ]][[]]][][[[   
]]]][[]][[[[                    ]]]][[]][[[[   
][[[[][[]]]]                    ][[[[][[]]]]   
][]][]]][[[[                    ][]][]]][[[[   
]][][[][][[]                    ]][][[][][[]   
]][][]][[][[                    ]][][]][[][[   
[][[]][]]][[    []              [[]][]]][[     
[[]]]]][[[[]    [[]]            ]]][[[[]       
]][[[[[[]]]]                    ]][[[[[[]]]]   
][][][[[]][]                    ][][][[[]][]   
[]][]][][][[    []              ][]][][][[     
]][[[][]][[]                    ]][[[][]][[]   
][[[[]]]][][                    ][[[[]]]][][   
[[]]]]][[][[    [[]]            ]]][[][[       

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!

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).
@(do
   (defun comb-n-m (n m)
     (comb (range* 0 n) m))

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

Run:
$ txr combinations.txr 
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))

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.
@(do
   (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   
$ txr command-line-args.txr 1 2 3 4
usage: txr command-line-args.txr   
$ 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")

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
$

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

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)

Output:
$ 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)

Output:
$ 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>

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"

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

@(do (defvar *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} 
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 `!echo "0\n1\n"`)
@  (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: ((t . "text1"))
Aborted

Factorial

Built-in

Via nPk function:
$ txr -p '(n-perm-k 10 10)'
3628800

Functional

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

Find limit of recursion

@(do
   (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.txr 
caught segfault!
reached depth: 2941

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.
@(do
   (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

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

@(do
   (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.txr 
error: need an argument
usage:
txr floyds-triangle.txr 
$ txr floyds-triangle.txr 1 2
error: too many arguments
usage:
txr floyds-triangle.txr 
$ txr floyds-triangle.txr 5
  1
  2  3
  4  5  6
  7  8  9 10
 11 12 13 14 15
$ txr floyds-triangle.txr 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:
@(do (defun mult (a b) (* a b))
    (put-line `3 * 4 = @(mult 3 4)`))

$ txr multiply2.txr
3 * 4 = 12

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

@(do
   (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 -c @(bind g @(gcd (expt 2 123) (expt 6 49)))
g="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

@(do
   (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.txr
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

@(do
   (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.txr 
#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.
@(do
   (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.txr
(((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/Newline omission

Possible using access to standard output stream via TXR Lisp:
$txr -c '@(do (format t "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

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

For exception symbols only.
@(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)

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

JSON

Parsing

The following implements the parsing half of the task. It is a parser closely based on the JSON grammar www.json.org/fatfree.html . It is implemented with recursive horizontal pattern matching functions, and so basically the definition resembles a grammar. Horizontal functions are a new feature in TXR, and basically 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 &#xABCD; and then the filter will produce the proper Unicode character. Similarly \" is translated to &quot; and \n is translated to etc. A little liberty is taken: the useless commas in JSON are treated as optional. 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 . "")

Letter frequency

Pattern Matching Plus Embedded Lisp

@(do (defvar h (make-hash nil nil t)))
@(collect :vars ())
@(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

@(do (let ((h (hash))
           (s (open-file "/usr/share/dict/words" "r")))
       (each ((ch (gun (get-char s))))
         (if (chr-isalpha ch)
           (inc [h (chr-toupper ch) 0])))
       (let ((sorted [sort (hash-pairs h) > second]))
         (each ((pair sorted))
           (tree-bind (key value) pair
              (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

Translation of Scheme

No "srfi -43" required:
@(do
   ;; Scheme's vector-for-each: a one-liner in TXR
   ;; that happily works over strings and lists.
   (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

Translation of Logo

@(do
   (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)

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

Mandelbrot set

Translation of Scheme

Creates same mandelbrot.pgm file.
@(do
    (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 scramble (list)
     (let ((out ()))
       (each ((item list))
         (let ((r (random *r* (+ 1 (length out)))))
           (set [out r..r] (list item))))
       out))

   (defun neigh (loc)
     (tree-bind (x . y) 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 (scramble (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. 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.
@(do
   (defvar vi)  ;; visited hash
   (defvar pa)  ;; path connectivity hash
   (defvar sc)  ;; count, derived from straightness fator

   (defun scramble (list)
     (let ((out ()))
       (each ((item list))
         (let ((r (rand (+ 1 (length out)))))
           (set [out r..r] (list item))))
       out))

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

   (defmacro while (expr . body)
     ^(for () (,expr) () ,*body))

   (defun neigh (loc)
     (tree-bind (x . y) loc
       (list (- x 1)..y (+ x 1)..y
             x..(- y 1) x..(+ y 1))))

   (defun make-maze-impl (cu)
     (let ((fr (hash :equal-based))
           (q (list cu))
           (c sc))
       (set [fr cu] t)
       (while q
         (let* ((cu (first q))
                (ne (rnd-pick (remove-if (orf vi fr) (neigh cu)))))
           (cond (ne (set [fr ne] t)
                     (push ne [pa cu])
                     (push cu [pa ne])
                     (push ne q)
                     (cond ((<= (dec c) 0)
                            (set q (scramble q))
                            (set c sc))))
                 (t (set [vi cu] t)
                    (del [fr cu])
                    (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: 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.
@(do
   (defmacro while ((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))
     (while ((< i 100))
       (if (< (inc i) 20)
         continue)
       (if (> i 30)
         break)
       (prinl i)))

   (prinl
     (sys:expand
       '(while ((< 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-0004 ;; broken into lines and indented by hand for readability!
  (for nil ((< i 100) nil) nil
     (block #:cnt-blk-0003 
       (if (< (inc i) 20)
         (return-from #:cnt-blk-0003))
       (if (> i 30)
         (return-from #:brk-blk-0004))
       (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

@(do
   (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 "QChuZXh0IDphcmdzKQpAZmlsZW5hbWUKQChuZXh0IGAhc2VkIC1uIC1lICcyLCRwJyBAZmlsZW5hbWUgfCBiYXNlNjRgKQpAKGZyZWVmb3JtICIiKQpAaW42NApAKG5leHQgYEBmaWxlbmFtZWApCkBmaXJzdGxpbmUKQChjYXNlcykKQCAgKGJpbmQgZmlyc3RsaW5lIGBAQChiaW5kIG15NjQgIkBteTY0IilgKQpAICAoYmluZCBpbjY0IG15NjQpCkAgIChiaW5kIHJlc3VsdCAiMSIpCkAob3IpCkAgIChiaW5kIHJlc3VsdCAiMCIpCkAoZW5kKQpAKG91dHB1dCkKQHJlc3VsdApAKGVuZCkK")
@(next :args)
@filename
@(next `!sed -n -e '2,$p' @filename | base64`)
@(freeform "")
@in64
@(next `@filename`)
@firstline
@(cases)
@  (bind firstline `@@(bind my64 "@my64")`)
@  (bind in64 my64)
@  (bind result "1")
@(or)
@  (bind result "0")
@(end)
@(output)
@result
@(end)

How to run, showing self -acceptance:
$ txr narcissist.txr narcissist.txr
1
Informal proof. We consider what happens if we make an alteration to the code and feed it to the original. Changing any character of narcissist.txr can be divided into two cases. These cases are an exhaustive partitioning of the possibilities; there are no ways to modify the data which do not land into one of these cases. Nothing in the query calls for any iteration or recursion. Termination depends on the base64 and sed utilities munching through the input, which presumably process an input of size N in O(N) steps. On that note, we could limit how many lines of the input are passed to base64 by using sed -n -e '2,20p' .

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") ("T" "cat") ("R" "bird")
   ("S " "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 T"
    "SW T CA R"
    "SW R CA S"
    "SW S 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!"
   "T: Imagine that! She swallowed a T!"
   "R: How absurd to swallow a R!"
   "S: 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 as nil ("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.
@(do
   ;; 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.txr '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.txr '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.txr '1 2 3 + +'
[ ... ]
infix: 1 + 2 + 3

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

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

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

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

$ txr rpn.txr '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")))

Power set

Translation of Common Lisp

The power set function can be written concisely like this:
(defun power-set (s)
 (reduce-right
   (op append (mapcar (op cons @@1) @2) @2)
   s '(())))

A complete program which takes command line arguments and prints the power set in comma -separated brace notation:
@(do (defun power-set (s)
       (reduce-right
         (op append (mapcar (op cons @@1) @2) @2)
         s '(()))))
@(bind pset @(power-set *args*))
@(output)
@  (repeat)
{@(rep)@pset, @(last)@pset@(empty)@(end)}
@  (end)
@(end)

$ txr rosetta/power-set.txr  1 2 3
{1, 2, 3}
{1, 2}
{1, 3}
{1}
{2, 3}
{2}
{3}
{}
What is not obvious is that the above power -set function generalizes to strings and vectors.
@(do (defun power-set (s)
       (reduce-right
         (op append (mapcar (op cons @@1) @2) @2)
         s '(())))
     (prinl (power-set "abc"))
     (prinl (power-set ""))
     (prinl (power-set #(1 2 3))))

txr power-set-generic.txr
((#\a #\b #\c) (#\a #\b) (#\a #\c) (#\a) (#\b #\c) (#\b) (#\c) nil)
((nil) nil)
((1 2 3) (1 2) (1 3) (1) (2 3) (2) (3) nil)

Prime decomposition

Translation of Common Lisp

@(next :args)
@(do
  (defun factor (n)
    (if (> n 1)
      (for ((max-d (sqrt n))
            (d 2))
           (t)
           ((set d (if (evenp d) (+ d 1) (+ d 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)

$ 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 &#10; 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: 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 sortdup (li)
     (let ((h [group-by identity li]))
       [sort (hash-keys h) <]))

   (defun rangeexpand (list)
     (sortdup (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.

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.
@(do (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)

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)

The :vars () argument to collect means that it still iterates, but doesn't actually collect anything (empty list of variables). This is important, so that there isn't a growing data structure being accumulated as the input is processed. Via TXR Lisp:
@(do
   (defun rot13 (ch)
     (cond
       ((<= #\A (chr-toupper ch) #\M) (+ ch 13))
       ((<= #\N (chr-toupper ch) #\Z) (- ch 13))
       (t ch)))

   (each ((l (gun (get-line nil))))
     (put-line [mapcar rot13 l])))

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 -c '@(do (print (read)) (put-line ""))'
((data "quoted data" 123 4.5)                <- input from TTY
 (data (!@# (4.5) "(more" "data)")))
((data "quoted data" 123 4.5) (data (! (sys:var #) (4.5) "(more" "data)")))   <- output

However, note that the @ character has a special meaning: @# turns into (sys:var #) . TXR's printer right now does not convert this back to @ notation upon printing (fixed in git master now). (The purpose of this notation is to support Lisp code that requires meta -variables: variables distinguished from variables. For instance, logic pattern matching or unification code. Instead of hacks like name -based conventions (for instance x? is a meta -variable, x is ordinary), why not build it into the language: @x is a meta -var, identifiable by special abstract syntax, and x is just an atom, a symbol. There is also @(foo ...) which expands into (sys:expr foo ...) , doing a similar thing for expressions. 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"

Self-referential sequence

Translation of Clojure

This is a close, almost expression -by -expression transliteration of the Clojure version.
@(do
   ;; 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.txr

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 .
@(do
   (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)))

  (let ((r (find-longest 1000000)))
    (format t "Longest: ~a\n" r)
    (ref-seq-len (first (first r)) t)))

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

@(do
   ;; 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

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 "-")
@(collect)
@BODY
@(end)
@(output `!mail -s "@SUBJ" -c "@CC" "@TO"`)
@(repeat)
@BODY
@(end)
.
@(end)

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

Set consolidation

Original solution:
@(do
   (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)) -> ((d c) (b a))
((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)) -> ((d c b a) (g f k i h))

Translation of Racket

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

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

   (defun consoli (ss)
     (defun comb (cs s)
       (cond ((empty-p s) cs)
             ((null cs) (list s))
             ((empty-p (hash-isec s (first cs)))
              (cons (first cs) (comb (rest cs) s)))
             (t (consoli (cons (hash-uni s (first cs)) (rest cs))))))
     [reduce-left comb 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)) -> ((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))

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")

$ 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.

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 (chr-str su 0)))
           (for ((i 1) (l (length su)) cp cg)
                ((< i l) (sub-str (cat-str ^(,o "000") nil) 0 4))
                ((inc i) (set cp cg))
             (set cg (get-code (chr-str su i)))
             (if (and cg (null (eql cg cp)))
               (set o (cat-str ^(,o ,cg) nil))))))))
@(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 @: 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): Atoms can be: Within literals and regexes: Within literals, quasiliterals and character constants: The regex syntax is fairly standard fare, with these extensions:

String matching

TXR Lisp

@(do
   (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`))
          ((match-str big small)
           (put-line `@small is a prefix of @big`))
          ((match-str big small -1)
           (put-line `@small is a suffix of @big`))
          (t (let ((pos (search-str big small)))
               (if pos
                 (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.txr x
usage: txr cmatch2.txr  
$ txr cmatch2.txr x y z
usage: txr cmatch2.txr  
$ txr cmatch2.txr catalog cat
cat is a prefix of catalog
$ txr cmatch2.txr catalog log
log is a suffix of catalog
$ txr cmatch2.txr catalog at
at occurs in catalog at position 1
$ txr cmatch2.txr catalog catalogue
catalog is shorter than catalogue
$ txr cmatch2.txr catalog catalog
catalog and catalog are equal
$ txr cmatch2.txr 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:
@(do
   (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.txr 
usage: txr strip-chars-2.txr  
$ txr strip-chars-2.txr "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

@(do
  (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:
@(do
   (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

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

@(do
   (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 ]

Variable-length quantity

In TXR, the preferred way to render data into octets is to convert it to a character string. Character strings are Unicode, which serializes to UTF -8 when sent to text streams.
@(do
   ;; show the utf8 bytes from byte stream as hex
   (defun put-utf8 (str : stream)
     (set stream (or stream *stdout*))
     (for ((s (make-string-byte-input-stream str)) byte)
          ((set byte (get-byte s)))
          ((format stream "\\x~,02x" byte))))

   ;; print
   (put-utf8 (tostring 0))
   (put-line "")
   (put-utf8 (tostring 42))
   (put-line "")
   (put-utf8 (tostring #x200000))
   (put-line "")
   (put-utf8 (tostring #x1fffff))
   (put-line "")

   ;; print to string and recover

   (format t "~a\n" (read (tostring #x200000)))
   (format t "~a\n" (read (tostring #x1f0000))))

Run:
\x30
\x34\x32
\x32\x30\x39\x37\x31\x35\x32
\x32\x30\x39\x37\x31\x35\x31
2097152
2031616

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

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 `!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 `!wget -c http://tycho.usno.navy.mil/cgi-bin/timer.pl -O - 2> /dev/null`)
@(skip)
<BR>@time@\ UTC@(skip)
@(output)
@time
@(end)

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:
@(do
  ;; 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 @@ is new in TXR 77. When the currying syntax is nested, code in an inner op/do can refer to numbered implicit parameters in an outer op/do . Each additional @ "escapes" out one nesting level.

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 `!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: Rosetta | Partner With Our Interactive Marketing Agency Today
URL: http://www.rosetta.com/Pages/default.aspx
TEXT: Learn about the fastest growing interactive marketing agency in the country - Rosetta. Our strategic marketing planning is custom built and connects you with your ...
---
TITLE: Official Rosetta Stone® - Learn a Language Online - Language ...
URL: http://www.rosettastone.com/
TEXT: Rosetta Stone is the world's #1 language-learning software. Our comprehensive foreign language program provides language learning for individuals and language learning ...
---
TITLE: Rosetta (software) - Wikipedia, the 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: Rosetta (spacecraft) - Wikipedia, the 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. Rosetta consists of two main elements: the Rosetta 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: Rosetta | Free Music, Tour Dates, Photos, Videos
URL: http://www.myspace.com/rosetta
TEXT:  Rosetta's official profile including the latest music, albums, songs, music videos and more updates.
---
TITLE: Rosetta
URL: http://rosettaband.com/
TEXT: Metal for astronauts. Philadelphia, since 2003. Contact us at rosettaband@gmail.com Twitter | Facebook
---
TITLE: Rosetta
URL: http://rosetta.jpl.nasa.gov/
TEXT: The Rosetta spacecraft is on its way to catch and land a robot on a comet! Rosetta will reach comet '67P/Churyumov-Gerasimenko' ('C-G') in 2014. The European Space Agency ...
---
TITLE: Rosetta : Multi-script Typography
URL: http://rosettatype.com/
TEXT: Rosetta 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: Rosetta (1999) - IMDb
URL: http://www.imdb.com/title/tt0200071/
TEXT: With Ãmilie Dequenne, Fabrizio Rongione, Anne Yernaux, Olivier Gourmet. Young and impulsive Rosetta lives with her alcoholic mother and, moved by despair, she will ...
---