## 100 doors↗

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

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

```

## 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
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
True
>>> can_make_word("CONFUSE")
True
```

## Accumulator factory↗

### Verbose

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

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

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

### Sugared

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

```
##### Output:
```\$ echo "1 2 3 4.5" | txr accumulator-factory2.tl
1 -> 1
2 -> 3
3 -> 6
4.5 -> 10.5
```

### Yield-based

Using the `obtain`/`yield` interface to delimited continuations, we can turn an imperative for loop into an accumulation function:
```(defun accum ()
(for ((sum (yield-from accum)))
()
((inc sum (yield-from accum sum)))))

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

```
##### Output:
```\$ echo "1 2 3 4.5" | txr accumulator-factory2.tl
1 -> 1
2 -> 3
3 -> 6
4.5 -> 10.5
```

### OOP-based

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

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

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

```

## Ackermann function↗

### Translation of Scheme

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

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

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

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

## 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
@(bind nc @[apply max [mapcar length item]])
@(bind pi @(mapcar (op append @1 (repeat '("") (- nc (length @1)))) item))
@(bind cw @(vector-list
(mapcar (op apply max [mapcar length @1])
;; matrix transpose trick cols become rows:
[apply mapcar [cons list pi]])))
@(bind ns "")
@(output)
@  (repeat)
@    (rep :counter i)@{pi @[cw i]} @(end)
@  (end)
@  (repeat)
@    (rep :counter i)@{pi @(- [cw i])} @(end)
@  (end)
@  (repeat)
@    (rep :counter i)@\
@{ns @(trunc (- [cw i] (length pi)) 2)}@\
@{pi @(- [cw i] (trunc (- [cw i] (length pi)) 2))} @(end)
@  (end)
@(end)

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

## Amb↗

#### Delimited Continuations

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

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

```
And some test code:
##### Output:
```\$ txr -i amb.tl
1> (amb-scope
(let ((w1 (amb "the" "that" "a"))
(w2 (amb "frog" "elephant" "thing"))
(w4 (amb "slowly" "quickly")))
(amb (and (eql [w1 -1] [w2 0])
(eql [w2 -1] [w3 0])
(eql [w3 -1] [w4 0])))
(list w1 w2 w3 w4)))
("that" "thing" "grows" "slowly")
2>
```

#### Pattern Language

This is not exactly the implementation of an operator, but a solution worth presenting. The language has the built in pattern matching and backtracking behavior suited for this type of text mining task. For convenience, we prepare the data in four files:
```\$ cat amb/set1
the
that
a
\$ cat amb/set2
frog
elephant
thing
\$ cat amb/set3
walked
grows
\$ cat amb/set4
slowly
quickly
```
Then code is:
```@(define first_last (first last whole))
@  (all)
@(skip :greedy)@{last 1}
@  (and)
@{first 1}@(skip)
@  (and)
@whole
@  (end)
@(end)
@(next "amb/set1")
@(skip)
@(first_last fi1 la1 w1)
@(next "amb/set2")
@(skip)
@(first_last la1 la2 w2)
@(next "amb/set3")
@(skip)
@(first_last la2 la3 w3)
@(next "amb/set4")
@(skip)
@(first_last la3 la4 w4)
@(output)
@w1 @w2 @w3 @w4
@(end)

```
##### Run:
```\$ ./txr amb.txr
that thing grows slowly
```
As you can see, this has the "nondeterministic flavor" of Amb. The `@(skip)` directives"magically" skip over the lines of input that do not succeed. This example naturally handles empty strings, since the `first_last` function simply does not match such inputs. Here is how to embed the task's specific data in the code:
```@(define first_last (first last whole))
@  (all)
@(skip :greedy)@{last 1}
@  (and)
@{first 1}@(skip)
@  (and)
@whole
@  (end)
@(end)
@(next :list ("the" "that" "a"))
@(skip)
@(first_last fi1 la1 w1)
@(next :list ("frog" "elephant" "thing"))
@(skip)
@(first_last la1 la2 w2)
@(skip)
@(first_last la2 la3 w3)
@(next :list ("slowly" "quickly"))
@(skip)
@(first_last la3 la4 w4)
@(output)
@w1 @w2 @w3 @w4
@(end)

```

## Anonymous recursion↗

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

### Translation of Common_Lisp

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

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

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

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

## Apply a callback to an array↗

Print 1 through 10 out of a vector, using `prinl` the callback, right from the system shell command prompt:
```\$ txr -e '[mapdo prinl #(1 2 3 4 5 6 7 8 9 10)]'
1
2
3
4
5
6
7
8
9
10

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

## Arbitrary-precision integers (included)↗

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

```
##### Output:
```62060698786608744707...92256259918212890625
ndigits=183231
```

## Arithmetic evaluation↗

Use TXR text pattern matching to parse expression to a Lisp AST, then evaluate with `eval`:
```@(next :args)
@(define space)@/ */@(end)
@(define mulop (nod))@\
@(local op)@\
@(space)@\
@(cases)@\
@{op /[*]/}@(bind nod @(intern op *user-package*))@\
@(or)@\
@{op /\//}@(bind (nod) @(list 'trunc))@\
@(end)@\
@(space)@\
@(end)
@(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)@\
@(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)
@  (output)
@  (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 left-adjusted in a 10 character field:

@{a 10}.

here are a through a 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}
@(end)
@(end)

```

#### Other Kinds of Objects

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

## Associative array/Iteration↗

```(defvarl h (hash))

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

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

```
##### Run:
```\$ txr hash.tl
c -> 3
b -> 2
a -> 1
```

## Balanced brackets↗

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

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

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

```
The recursive pattern function `@(paren)` gives rise to a grammar which matches parentheses:
```@(define paren)@(maybe)[@(coll)@(paren)@(until)]@(end)]@(end)@(end)
```
A string of balanced parentheses is an optional unit (`@(maybe) ... @(end)`) that begins with `[`, followed by zero or more such balanced strings, followed by `]`. Sample run:
```\$ ./txr paren.txr
INPUT           MATCHED         REST
][[[]][][[]]                    ][[[]][][[]]
[]][[]][][[]    []              ][[]][][[]
[][[[[]]]]][    []              [[[[]]]]][
][[][[]]][][                    ][[][[]]][][
[[[][[]]][]]    [[[][[]]][]]
]][]][[[][[]                    ]][]][[[][[]
[[]][]][[[]]    [[]]            []][[[]]
]][]][]][[[[                    ]][]][]][[[[
]][[]]][][[[                    ]][[]]][][[[
]]]][[]][[[[                    ]]]][[]][[[[
][[[[][[]]]]                    ][[[[][[]]]]
][]][]]][[[[                    ][]][]]][[[[
]][][[][][[]                    ]][][[][][[]
]][][]][[][[                    ]][][]][[][[
[][[]][]]][[    []              [[]][]]][[
[[]]]]][[[[]    [[]]            ]]][[[[]
]][[[[[[]]]]                    ]][[[[[[]]]]
][][][[[]][]                    ][][][[[]][]
[]][]][][][[    []              ][]][][][[
]][[[][]][[]                    ]][[[][]][[]
][[[[]]]][][                    ][[[[]]]][][
[[]]]]][[][[    [[]]            ]]][[][[
```

## 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!'
decoded: Vszzc, kcfzr!
\$ ./txr caesar.txr 12 'Vszzc, kcfzr!'
encoded: Hello, world!
decoded: Jgnnq, yqtnf!

```

## Call a foreign-language function↗

```This is the TXR Lisp interactive listener of TXR 176.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (with-dyn-lib nil
(deffi strdup "strdup" str-d (str)))
#:lib-0177
2> (strdup "hello, world!")
"hello, world!"
```
The requirement to free the memory is taken care of the semantics of the `str-d` ("dynamic") variant of the `str` type. The semantics denotes the passage of ownership of `malloc`-ed memory across the interface. When the C-to-Lisp value conversion takes place on the return value, FFI releases the memory, knowing that it has received ownership of it from the function, which entails that responsibility. If the `str` type were used by mistake, a memory leak would result. There is no way to use the `str` family of types, yet do manual memory management; FFI manages automatically. Code that wants to manually manage a foreign resource referenced by pointer should use `cptr` or `carray`, depending on required semantics.

## Call a function in a shared library↗

#### Call `uname` on Linux

```This is the TXR Lisp interactive listener of TXR 176.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (typedef utsarray (zarray 65 char))
#<ffi-type (zarray 65 char)>
2> (typedef utsname (struct utsname (sysname utsarray)
(nodename utsarray)
(release utsarray)
(version utsarray)
(machine utsarray)
(domainname utsarray)))
#<ffi-type (struct utsname (sysname utsarray) (nodename utsarray) (release utsarray)
(version utsarray) (machine utsarray) (domainname utsarray))>
3> (with-dyn-lib nil (deffi uname "uname" int ((ptr-out utsname))))
** warning: (expr-3:1) defun: redefining uname, which is a built-in defun
#:lib-0176
4> (let ((u (new utsname))) (prinl (uname u)) u)
0
#S(utsname sysname "Linux" nodename "zelenka" release "3.2.0-40-generic"
version "#64-Ubuntu SMP Mon Mar 25 21:22:26 UTC 2013" machine "i686"
domainname "(none)")
```
We use `typedef` to condense the declarations, much like in C. The FFI handles nested types like arrays in structures. The `zarray` type denotes null-terminated arrays. A `zarray` of `char` is specialized; it converts between Lisp strings (which use wide characters made of Unicode code points) and C `char` strings encoded in UTF-8. The argument of `uname` is `(ptr-out utsname)`. The semantics of `ptr-out` in this situation is that FFI prepares a C version of the Lisp structure, but doesn't perform any conversions from Lisp to initialize it. This not only saves CPU cycles, but allows us to use a blank structure produced by `(new utsname)` all of whose slots are `nil` and so wouldn't convert to C character arrays anyway! The function is called, and then conversions out of the structure to the Lisp structure take place, filling its slots with string values. The `nil` argument in the `with-dyn-lib` macro causes the underlying implementation to call `dlopen(NULL)` to get access to the dynamic symbols available in the executable. We can use the name of a shared library instead, or a handle from TXR's `dlopen` library function.

## Classes↗

```(defstruct shape ()
cached-area

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

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

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

(defstruct circle shape

(:method calc-area (self)

(defstruct square shape
(length 1.0)

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

```
##### Output:
```\$ txr -i shapes.tl
1> (let ((s (new circle)))
s.(area))
#S(circle cached-area nil radius nil) is born!
3.14159265358979
2> (sys:gc)
#S(circle cached-area 3.14159265358979 radius 1.0) says goodbye!
t
3>
```
Notes:
• `defstruct` and `new` are macros which compile to invocations of the functions `make-struct-type` and `make-struct`.
• The `obj.fun(x, y)` syntax is "halfway Lispified", and looks like `obj.(fun x y)`. This denotes a method call: the function `fun` is retrieved from the object, and passed the arguments `(obj x y)`.
• The notation `obj.[fun x y]` is similar, but will '''not''' pass `obj` to fun; it is for calling static functions (class utility functions that don't require an instance).
• `a.b.c.d` in TXR Lisp is a syntactic sugar for the expression `(qref a b c d)`, where the elements may be compound expressions. Thus `obj.(a b).c` is `(qref obj (a b) c)`.
• There must be no whitespace around the dot: `(a . b)` is the consing dot whereas `(a.b)` is the syntax `((qref a b))`.
• Ambiguity with floating-point numbers isn't allowed. For instance, `a.b.1` elicits an error from the parser (lexical scanner actually).

## Closures/Value capture↗

#### Sugared

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

```
##### Output:
```(1 4 9 16 25 36 49 64 81)

```

### Translation of Emacs Lisp

The explicit `lambda` structure here is much like the implicit ones in the "Sugared" example:
```;; Dropping distracting "skip last" requirement
;; (not implemented in original Elisp either).
(mapcar 'call
(mapcar (lambda ()
(lambda () (* x x))) '(1 2 3 4 5 6 7 8 9 10)))

```

#### Delimited Continuations

In this interactive example, we capture delimited continuations inside a simple `for` loop. Because the variable binding environment is not necessarily in the stack which is captured, we rebind the loop variable.
```This is the TXR Lisp interactive listener of TXR 124.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (let ((conts))
(for ((i 0)) ((< i 10) (nreverse conts)) ((inc i))
(let ((cap i))
(push (block sqr
(suspend sqr f (op f nil))
(* cap cap))
conts))))
(#<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>
#<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>
#<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>
#<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>
#<interpreted fun: lambda #:rest-0112> #<interpreted fun: lambda #:rest-0112>)
2> (call (first *1))
0
3> (call (second *1))
1
4> (call (fifth *1))
16
5> (call [*1 4])
16
6> (call [*1 7])
49
```
The `suspend` operator suspends the execution of the `sqr` block, causing it to return the function `(op f nil)`. The variable `f` represents the captured continuation as a function. Continuation functions take one mandatory argument. We don't need that here, hence the `(op f nil)` expression is returned: it curries the one arg continuation function `f` to a function with no arguments. The loop pushes these suspended continuations into a list, and then `nreverse`-s it. We then interactively call the continuations in the list. Whenever we call a continuation, the `(block sqr ...)` environment is restored. and the suspended computation inside the block resumes by returning out of the `(suspend ...)` form normally. The block then executes to completion, returning the `(* cap cap)` form's value. At that point, our call to the continuation terminates, yielding that value.

## Combinations↗

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

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

```
##### Run:
```\$ txr combinations.tl
3 comb 5 = ((0 1 2) (0 1 3) (0 1 4) (0 2 3) (0 2 4) (0 3 4) (1 2 4) (1 3 4) (2 3 4))
```

## Combinations with repetitions↗

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

```
##### Output:
```
((iced iced) (iced jam) (iced plain) (jam jam) (jam plain) (plain plain))

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

```
```
220

```

## Comma quibbling↗

```(defun quib (list)
(tree-bind (: last . lead) (reverse list)

```

## Command-line arguments↗

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

```
```\$ ./txr args.txr
My args are: {}
\$ ./txr args.txr 1
My args are: {1}
\$ ./txr args.txr 1 2 3
My args are: {1, 2, 3}
```
Arguments are also available via two predefined variables: `*full-args*` and `*args*`, which are lists of strings, such that `*args*` is a suffic of `*full-args*`. `*full-args*` includes the arguments that were processed by TXR itself; `*args*` omits them. Here is an example program which requires exactly three arguments. Note how `ldiff` is used to compute the arguments that are processed by TXR (the interpreter name, any special arguments and script name), to print an accurate usage message.
```(tree-case *args*
((a b c) (put-line "got three args, thanks!"))
(else (put-line `usage: @(ldiff *full-args* *args*) <arg1> <arg2> <arg3>`)))

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

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

```

## Compound data type↗

In TXR Lisp, a structure type can be created:
```(defstruct point nil (x 0) (y 0))

```
If it is okay for the coordinates to be initialized to nil, it can be condensed to:
```(defstruct point nil x y)

```
The nil denotes that a point has no supertype: it doesn't inherit from anything. This structure type can then be instantiated using the new macro (not the only way):
```(new point)         ;; -> #S(point x 0 y 0)
(new point x 1)     ;; -> #S(point x 1 y 0)
(new point x 1 y 1) ;; -> #S(point x 1 y 1)

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

```
The existing construction methods continue to work, but in addition, this is now possible:
```(new (point 3 4)) -> #S(point x 3 y 4)

```
Slot access syntax is supported. If variable p holds a point, then p.x designates the x slot, as a syntactic place which can be accessed and stored:
```(defun displace-point-destructively (p delta)
(inc p.x delta.x)
(inc p.y delta.y))

```

## Conditional structures↗

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

```
Suppose the input is something which can match all three patterns in different ways:
```foo<--bar:baz+xyzzy
```
The outcome (with `txr -B`) will be:
```x="foo"
y="bar:baz+xyzzy"
```
because this match minimizes the length of `x`. If we change this to `:longest x`, we get:
```x="foo<--bar:baz"
y="xyzzy"
```
The `cases`, `all` and `none` directives most resemble control structures because they have short-circuiting behavior. For instance:
```@(all)
@x:y@
@z<-@w
@(and)
@(output)
We have a match: (x, y, z, w) = (@x, @y, @z, @w).
@(end)
@(end)

```
If any subclause fails to match, then `all` stops processing subsequent clauses. There are subtleties though, because an earlier clause can produce variable bindings which are visible to later clauses. If previously bound variable is bound again, it must be to an identical piece of text:
```@# match a line which contains some piece of text x
@# after the rightmost occurence of : such that the same piece
@# of text also occurs at the start of the line preceded by -->
@(all)
@*junk:@x
@(and)
-->@x@/.*/
@(end)

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

## Count occurrences of a substring↗

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

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

## CRC-32↗

### Standard Library

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

```
##### Output:
```1095738169
```

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

```
##### Output:
```\$ txr -i crc32-zlib.tl
1> (let ((s "The quick brown fox jumps over the lazy dog"))
(zlib-crc32 0 s (coded-length s)))
1095738169
```
Note: `coded-length` gives UTF-8 length; `len` yields a code point count. Since this is an ASCII string, the two agree.

### Lisp Code

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

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

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

## CSV data manipulation↗

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

```

## CSV to HTML translation↗

#### Simple

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

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

```

#### With Styling

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

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

```

## Currying↗

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

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

```
Or, by referring to the definition of `f`:
```(defun g (x)
(lambda (y)
(lambda (z)
(f x y z))))

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

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

```
Run:
```\$ txr -B division-by-zero.txr
good="4.0"
```

## Determine if only one instance is running↗

#### Microsoft Windows

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

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

(with-dyn-lib "kernel32.dll"
(deffi CreateMutex "CreateMutexW" HANDLE (LPSECURITY_ATTRIBUTES BOOL LPCWSTR))
(deffi CloseHandle "CloseHandle" BOOL (HANDLE))
(deffi GetLastError "GetLastError" WINERR ()))

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

;; mutual exclusion here
)

(CloseHandle m)

```

## Empty string↗

#### Pattern Matching

```@(bind a "")

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

#### TXR Lisp

```(defvarl a "")

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

(set a "nonempty")

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

```

## Environment variables↗

TXR can treat the environment vector as text stream:
```@(next :env)
@(collect)
@VAR=@VAL
@(end)

```
A recently added `gather` directive is useful for extracting multiple items of data from an unordered stream of this kind (not only the environment vector):
```@(next :env)
@(gather)
HOME=@home
USER=@user
PATH=@path
@(end)

```
What if some of the variables might not exist? Gather has some discipline for that. The following means that three variables are required (the gather construct fails if they are not found), but `shell` is optional with a default value of `/bin/sh` if it is not extracted from the data:
```@(next :env)
@(gather :vars (home user path (shell "/bin/sh")))
HOME=@home
USER=@user
PATH=@path
SHELL=@shell
@(end)

```
From TXR Lisp, the environment is available via the `(env)` function, which returns a raw list of `"name=value` strings. The `(env-hash)` function returns a hash from environment keys to their values.
```\$ ./txr -p "(mapcar (env-hash) '(\"HOME\" \"USER\" \"PATH\"))"
("/home/kaz" "kaz" "/home/kaz/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/games:/home/kaz/bin"

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

## Evaluate binomial coefficients↗

nCk is a built-in function, along with the one for permutations, nPk:
```\$ txr -p '(n-choose-k 20 15)'
15504

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

```

## Exceptions↗

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

```
Sample interactive run. Here the input is typed into standard input from the tty. The output is interleaved with the input, since TXR doesn't reads ahead only as much data as it needs.
```\$ txr primates.txr -
[TTY]human Harry
[TTY]gorilla Gordon
[OUT]we have a primate Harry of kind human
[TTY]monkey Mike
[OUT]we have a primate Gordon of kind gorilla
[TTY][Ctrl-D/EOF]
[OUT]we have a primate Mike of kind monkey

```

## Exceptions/Catch an exception thrown in a nested call↗

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

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

```

### Translation of CommonLisp

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

```

## Factorial↗

### Built-in

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

```

### Functional

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

```

## File input/output↗

As a character string:
```(let ((var (file-get-string "input.txt")))
(file-put-string "output.txt" var))

```
As a list of lines:
```(let ((var (file-get-lines "input.txt")))
(file-put-lines "output.txt" var))

```

## Find limit of recursion↗

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

(defvar *count* 0)

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

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

```
##### Output:
```\$ txr limit-of-recursion.tl
caught segfault!
reached depth: 10909
```

## Find URI in text↗

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

```
Test file:
```\$ cat url-data
Blah blah http://en.wikipedia.org/wiki/Erich_Kästner_(camera_designer). (Handled by http://mediawiki.org/).
Confuse the parser: http://en.wikipedia.org/wiki/-)
ftp://domain.name/path(balanced_brackets)/foo.html
ftp://domain.name/path(balanced_brackets)/ending.in.dot.
ftp://domain.name/path(unbalanced_brackets/ending.in.dot.
```
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
ftp://domain.name/path/embedded?punct/uation
ftp://domain.name/dangling_close_paren
```

## First-class functions↗

### Translation of Racket

Translation notes: we use `op` to create cube and inverse cube anonymously and succinctly. `chain` composes a variable number of functions, but unlike `compose`, from left to right, not right to left.
```(defvar funlist [list sin
cos
(op expt @1 3)])

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

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

```
```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="1"
foo="2"
foo="3"
foo="4"
foo="5"
foo="6"
foo="7"
foo="8"
bar="1"
bar="2"
bar="3"
bar="4"
bar="5"
bar="6"
bar="7"
bar="8"
```

## Floyd's triangle↗

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

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

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

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

## Function definition↗

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

```
```\$ txr -B multiply.txr
result="12"
```
In the embedded Lisp dialect, it is possible to write an ordinary function that returns a value:
```(defun mult (a b) (* a b))
(put-line `3 * 4 = @(mult 3 4)`)

```
```\$ txr multiply.tl
3 * 4 = 12
```

## Generic swap↗

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

#### Naive macro

This allows multiple evaluation of the argument expressions.
```(defmacro swp (left right)
(with-gensyms (tmp)
^(let ((,tmp ,left))
(set ,left ,right
,right ,tmp))))

```

#### Using `placelet`

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

```

#### Using place expanders

Finally, the following is closely based on how `swap` is actually implemented in TXR Lisp's library. This explicitly uses the general mechanism for handling places, on which `placelet` is based also:
```(defmacro swp (left right :env env)
(with-gensyms (tmp)
(with-update-expander (l-getter l-setter) left env
(with-update-expander (r-getter r-setter) right env
^(let ((,tmp (,l-getter)))
(,l-setter (,r-getter))
(,r-setter ,tmp))))))

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

## Globally replace text in several files↗

### Extraction Language

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

```
Run:
```\$ cat foo.txt
aaaGoodbye, London!aaa
Goodbye, London!
\$ cat bar.txt
aaaGoodbye, London!aaa
Goodbye, London!
\$ txr replace-files.txr foo.txt bar.txt
\$ cat foo.txt
aaaHello, New York!aaa
Hello, New York!
\$ cat bar.txt
aaaHello, New York!aaa
Hello, New York!
```
Run, with no directory permissions:
```\$ chmod a-w .
\$ txr replace-files.txr foo.txt bar.txt
txr: unhandled exception of type file_error:
txr: could not open foo.txt.tmp (error 13/Permission denied)

```

### TXR Lisp

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

```

## Greatest common divisor↗

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

```

## Hailstone sequence↗

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

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

## Handle a signal↗

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

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

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

caught signal 2 after 6 seconds of execution
```
`range` generates a range of integers as a lazy list, which is infinite if the endpoint argument is omitted. We walk this infinite list using `each` like any other list.

## Hash from two arrays↗

### One-liner, using quasiquoted hash syntax

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

```

### One-liner, using `hash-construct` function

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

```

### Explicit construction and stuffing

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

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

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

## Hash join↗

Generic hash join. Arguments `left-key` and `right-key` are functions applied to the elements of the `left` and `right` sequences to retrieve the join key.
```(defvar age-name '((27 Jonah)
(18 Alan)
(28 Glory)
(18 Popeye)
(28 Alan)))

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

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

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

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

## Hello world/Graphical↗

#### Microsoft Windows

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

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

```

## Hello world/Newline omission↗

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

```

## Here document↗

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

The Computer
@(end)

```
Test runs
```
\$ ./quota.txr -DMB=20
Dear Unknown User

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

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

The Computer

```
Unbound variables throw exceptions:
```
\$ txr -c '@(output)
@FOO
@(end)'
txr: unhandled exception of type query_error:

```

## Higher-order functions↗

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

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

## Host introspection↗

Interactive session: Which word? Pointer size or size of `int`? Let's get both:
```This is the TXR Lisp interactive listener of TXR 177.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (sizeof (ptr char))
8
2> (sizeof int)
4
```
Endianness: what we can do is put the integer 1 into a buffer as a `uint32`, the 32 bit unsigned integer type in the local representation. We then retrieve it as a `le-uint32`: little-endian `uint32`:
```3> (ffi-put 1 (ffi uint32))
#b'01000000'
4> (ffi-get *3 (ffi le-uint32))
1
```
The extracted value 1 matches, so the machine must be little endian. Here is a transcript from a big-endian PPC64 machine:
```1> (ffi-put 1 (ffi uint32))
#b'00000001'
2> (ffi-get *1 (ffi le-uint32))
16777216
```
No match, so big endian.

## Increment a numerical string↗

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

#### TXR Lisp

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

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

#### No TXR Lisp

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

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

## Inheritance/Single↗

#### Inheritance among symbolic exception tags

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

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

```
##### Output:
Test:
```\$ txr dog-cat.txr
arg="x"
```

#### OOP Inheritance in TXR Lisp

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

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

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

(defstruct lab dog)

(defstruct collie dog)

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

```
##### Output:
```Lassie: bark!
Max: meow!
```

## JSON↗

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

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

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

```

## Keyboard input/Obtain a Y or N response↗

This works not only on Unix-like platforms, but also on Microsoft Windows, because TXR is ported to Windows using a [https://www.kylheku.com/cygnal/index.html modified version of Cygwin].
```(with-resources ((tio-orig (tcgetattr) (tcsetattr tio-orig)))
(let ((tio (copy tio-orig)))
tio.(go-raw)
(tcsetattr tio tcsaflush) ;; third arg optional, defaults to tcsadrain
(whilet ((k (get-char))
((not (member k '(#\y #\n #\Y #\N))))))))

```
The `go-raw` method on the `termios` structure only manipulates the structure contents; `tcsetattr` pushes it down to the TTY driver. `go-raw` is defined in the TXR standard library like this:
```(defmeth termios go-raw (tio)
tio.(clear-iflags ignbrk brkint parmrk istrip inlcr igncr icrnl ixon)
tio.(clear-oflags opost)
tio.(clear-cflags csize parenb)
tio.(clear-lflags echo echonl icanon isig)
(if (boundp 'iexten)
tio.(clear-lflags iexten))
tio.(set-cflags cs8)
(set tio.[cc vmin] 1)
(set tio.[cc vtime] 0))

```

## Least common multiple↗

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

```

## Letter frequency↗

### TXR Extraction Language plus TXR Lisp

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

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

### TXR Lisp

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

```

## Loop over multiple arrays simultaneously↗

### Pattern language

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

```

### TXR Lisp, using `mapcar`

Here we actually loop over four things: three strings and an infinite list of newlines. The output is built up as one string object that is finally printed in one go.
```\$ txr -e '(pprint (mappend (op list) "abc" "ABC" "123"
(repeat "\n"))))'
aA1
bB2
cC3

```

### TXR Lisp, using `each`

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

```

### Translation of Scheme

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

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

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

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

```

### Translation of Logo

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

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

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

(defun show (x) (pprinl x))

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

```
##### Output:
```(aA1 bB2 cC3)
```

## 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
1234567812345670 -> good
```

## Man or boy test↗

The goal in this solution is to emulate the Algol 60 solution as closely as possible, and not merely get the correct result. For that, we could just crib the Common Lisp or Scheme solution, with more succinct syntax, like this:
```(defun A (k x1 x2 x3 x4 x5)
(labels ((B ()
(dec k)
[A k B x1 x2 x3 x4]))
(if (<= k 0) (+ [x4] [x5]) (B))))

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

```
To do a proper job, we define a call-by-name system as a set of functions and macros. With these, the function `A` can be defined as a close transliteration of the Algol, as can the call to `A` with the integer constants:
```(defun-cbn A (k x1 x2 x3 x4 x5)
(let ((k k))
(labels-cbn (B ()
(dec k)
(set B (set A (A k (B) x1 x2 x3 x4))))
(if (<= k 0)
(set A (+ x4 x5))
(B))))) ;; value of (B) correctly discarded here!

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

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

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

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

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

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

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

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

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

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

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

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

```

## Mandelbrot set↗

### Translation of Scheme

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

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

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

(defsymacro c0 '(0 . 0))

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

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

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

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

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

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

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

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

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

(plot)

```

## Maze generation↗

### Simple, Depth-First

Legend: cu = current location; vi = boolean hash of visited locations; pa = hash giving a list neighboring cells to which there is a path from a given cell.
```@(bind (width height) (15 15))
@(do
(defvar *r* (make-random-state nil))
(defvar vi)
(defvar pa)

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

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

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

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

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

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

```
##### Output:
```+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+
|    |         |                        |                                  |
|    |         |                        |                                  |
+    +    +    +    +    +----+----+    +    +----+----+----+    +    +----+
|    |    |         |         |         |         |         |    |         |
|    |    |         |         |         |         |         |    |         |
+    +----+----+----+----+    +----+----+    +----+    +    +    +----+    +
|                   |         |              |         |    |    |         |
|                   |         |              |         |    |    |         |
+----+----+----+    +    +    +    +----+----+    +----+    +    +    +----+
|              |    |    |    |    |         |    |    |    |    |         |
|              |    |    |    |    |         |    |    |    |    |         |
+    +----+    +    +    +----+    +    +----+    +    +    +    +----+    +
|         |    |    |                   |         |    |    |         |    |
|         |    |    |                   |         |    |    |         |    |
+----+    +    +    +----+----+----+----+    +----+    +    +----+----+    +
|         |    |                   |         |         |              |    |
|         |    |                   |         |         |              |    |
+    +----+    +----+----+----+    +    +----+    +----+----+----+    +    +
|    |                        |         |                        |    |    |
|    |                        |         |                        |    |    |
+----+    +    +----+----+----+----+----+----+----+----+----+    +    +    +
|         |    |                                       |         |         |
|         |    |                                       |         |         |
+    +----+    +    +----+----+    +----+----+----+    +    +    +----+    +
|    |         |    |    |         |              |         |    |         |
|    |         |    |    |         |              |         |    |         |
+    +----+    +    +    +    +----+----+    +    +----+----+    +    +----+
|         |    |         |    |              |              |    |    |    |
|         |    |         |    |              |              |    |    |    |
+    +    +----+    +----+    +    +----+----+----+----+----+    +    +    +
|    |              |         |         |                   |    |         |
|    |              |         |         |                   |    |         |
+    +----+----+----+    +----+----+    +    +----+----+    +    +----+    +
|              |    |    |              |    |         |         |         |
|              |    |    |              |    |         |         |         |
+----+----+    +    +    +----+    +----+    +    +    +----+----+    +----+
|    |              |         |                   |              |    |    |
|    |              |         |                   |              |    |    |
+    +    +----+----+----+    +    +----+----+----+----+----+    +    +    +
|         |                   |              |              |    |         |
|         |                   |              |              |    |         |
+    +----+    +----+----+----+----+----+----+    +----+    +----+----+    +
|         |                                            |                   |
|         |                                            |                   |
+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+
```

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

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

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

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

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

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

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

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

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

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

```
##### Output:
Three mazes are generated, at the lowest, intermediate and highest "straightness factors". It is immediately obvious that the style of each maze is quite different.
```
# 10x10 maze with zero percent "straightness factor"
\$ txr maze-generation3.txr 10 10 0
+----+----+----+----+----+----+----+----+----+----+
|                   |    |                        |
|                   |    |                        |
+    +    +----+----+    +    +    +----+----+----+
|    |         |              |         |         |
|    |         |              |         |         |
+    +    +----+    +----+----+----+----+    +    +
|    |    |                   |              |    |
|    |    |                   |              |    |
+    +----+    +----+    +----+    +----+----+----+
|                   |                             |
|                   |                             |
+----+    +    +    +    +    +    +----+----+----+
|         |    |    |    |    |                   |
|         |    |    |    |    |                   |
+----+    +    +----+----+    +----+----+----+    +
|         |              |                   |    |
|         |              |                   |    |
+    +----+    +----+----+    +    +    +----+    +
|    |                   |    |    |         |    |
|    |                   |    |    |         |    |
+    +----+    +    +    +    +    +    +    +    +
|    |         |    |    |    |    |    |    |    |
|    |         |    |    |    |    |    |    |    |
+----+    +    +----+    +    +    +----+----+    +
|         |         |    |    |         |         |
|         |         |    |    |         |         |
+    +    +    +    +----+----+----+----+----+    +
|    |    |    |                        |         |
|    |    |    |                        |         |
+----+----+----+----+----+----+----+----+----+----+

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

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

## Metaprogramming↗

TXR has a built-in Lisp dialect called TXR Lisp, which supports meta-programming, some of which is patterned after ANSI Common Lisp. TXR provides:
• run-time access to its parser for Lisp expressions: `(read "(+ a b c)")`;
• a parser for regular exprssions: `(regex-parse "a.*b")` which produces abstract syntax;
• a run-time compiler for converting regular expression abstract syntax to compiled regular expression object;
• a `eval` function which expands and evaluates Lisp abstract syntax;
• global as well as lexically scoped macros, for both compound forms (with automatically destructured parameter lists) and symbols (symbol macros): the operators `defmacro`, `defsymacro`, `macrolet` and `symacrolet`;
• structural quasiquote for convenient macro writing.
Example define a while loop which supports break and continue. Two forms of break are supported `break` which causes the loop to terminate with the return value `nil` and `(break <form>)` which returns the specified value.
```(defmacro whil ((condition : result) . body)
(let ((cblk (gensym "cnt-blk-"))
(bblk (gensym "brk-blk-")))
^(macrolet ((break (value) ^(return-from ,',bblk ,value)))
(symacrolet ((break (return-from ,bblk))
(continue (return-from ,cblk)))
(block ,bblk
(for () (,condition ,result) ()
(block ,cblk ,*body)))))))

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

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

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

## Modular exponentiation↗

```\$ 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="./multilineshebang.txr"
\$ ./multilineshebang.txr 1
arg="./multilineshebang.txr"
arg="1"
\$ ./multilineshebang.txr 1 2 3
arg="./multilineshebang.txr"
arg="1"
arg="2"
arg="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 '==='
"" {==} "" {=} ""
```

### Translation of Racket

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

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

## Mutual recursion↗

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

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

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

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

## Narcissist↗

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

```
##### Output:
```\$ txr narcissist.txr narcissist.txr
1
```

## 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.
```;; alias for circumflex, which is reserved syntax
(defvar exp (intern "^"))

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

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

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

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

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

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

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

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

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

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

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

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

```
Associativity tests (abbreviated output):
```\$ txr rpn.tl '1 2 3 + +'
[ ... ]
infix: 1 + 2 + 3

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

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

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

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

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

## Partial function application↗

Partial application is built in via the `op` operator, so there is no need to create all these named functions, which defeats the purpose and beauty of partial application: which is to partially apply arguments to functions in an anonymous, implicit way, possibly in multiple places in a single expression. Indeed, functional language purists would probably say that even the explicit `op` operator spoils it, somewhat.
```\$ txr -p "(mapcar (op mapcar (op * 2)) (list (range 0 3) (range 2 8 2)))"
((0 2 4 6) (4 8 12 16))

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

```
Note how in the above, no function arguments are explicitly mentioned at all except the necessary reference `@1` to an argument whose existence is implicit. Now, without further ado, we surrender the concept of partial application to meet the task requirements:
```\$ txr -e "(progn
(defun fs (fun seq) (mapcar fun seq))
(defun f1 (num) (* 2 num))
(defun f2 (num) (* num num))
(defvar fsf1 (op fs f1))  ;; pointless: can just be (defun fsf1 (seq) (fs f1 seq)) !!!
(defvar fsf2 (op fs f2))

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

```

## Pick random element↗

### Translation of Tcl

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

```

## Power set↗

The power set function can be written concisely like this:
```(defun power-set (s)
(mappend* (op comb s) (range 0 (length s))))

```
This generates the lists of combinations of all possible lengths, from 0 to the length of `s` and catenates them. The `comb` function generates a lazy list, so it is appropriate to use `mappend*` (the lazy version of `mappend`) to keep the behavior lazy. A complete program which takes command line arguments and prints the power set in comma-separated brace notation:
```@(do (defun power-set (s)
(mappend* (op comb s) (range 0 (length s)))))
@(bind pset @(power-set *args*))
@(output)
@  (repeat)
{@(rep)@pset, @(last)@pset@(empty)@(end)}
@  (end)
@(end)

```
##### Output:
```\$ txr rosetta/power-set.txr  1 2 3
{1, 2, 3}
{1, 2}
{1, 3}
{1}
{2, 3}
{2}
{3}
{}
```
The above `power-set` function generalizes to strings and vectors.
```@(do (defun power-set (s)
(mappend* (op comb s) (range 0 (length s))))
(prinl (power-set "abc"))
(prinl (power-set "b"))
(prinl (power-set ""))
(prinl (power-set #(1 2 3))))

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

## Prime decomposition↗

### Translation of Common Lisp

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

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

## Program name↗

Given this code in `program-name.txr`, marked executable:
```#!/usr/local/bin/txr -B
@(bind my-name @self-path)

```
If we run it as an executable:
```\$ ./program-name.txr
my-name="./program-name.txr"
```
If we pass it as an argument to `txr`:
```\$ txr program-name.txr
my-name="program-name.txr"
```
If we evaluate the same thing on the command line:
```\$ txr -c '@(bind my-name @self-path)'
my-name="cmdline"
```
If we pass in the code on standard input:
```\$ txr -
@(bind my-name @self-path)
my-name="stdin"
```

## Quine↗

A suite for four variations on a theme. The first three use HTML encoding to avoid solving quoting problem. The third stops using `&#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:
• a parse-expression-grammar driven parser to decimate the input to a Lisp data structure;
• some Lisp code to expand the list, sort it, and remove duplicates (recursion, hashing, sorting).
• driver code which matches the input with the grammar, and produces output with the help of the Lisp code.
The grammar is:
```num := [ + | - ] { digit } +

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

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

(defun rangeexpand (list)
(uniq (expand-helper list))))
@(repeat)
@(rangelist x)@{trailing-junk}
@(output)
raw syntax: @x
expansion:  @(rangeexpand x)
@(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)
-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)
-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)
```
Note how the junk in the last example does not contain the trailing comma. This is because the rangelist grammar production allows for an empty range, so syntax like "5," is valid: it's an entry followed by a comma and a rangelist, where the rangelist is empty.

## Range extraction↗

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

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

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.

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

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

## Regular expressions↗

### Search and replace: simple

Txr is not designed for sed-like filtering, but here is how to do `sed -e 's/dog/cat/g'`:
```@(collect)
@(coll :gap 0)@mismatch@{match /dog/}@(end)@suffix
@(output)
@(rep)@{mismatch}cat@(end)@suffix
@(end)
@(end)

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

### Search and replace: strip comments from C source

Based on the technique of the previous example, here is a query for stripping C comments from a source file, replacing them by a space. Here, the "non-greedy" version of the regex Kleene operator is used, denoted by `%`. This allows for a very simple, straightforward regex which correctly matches C comments. The `freeform` operator allows the entire input stream to be treated as one big line, so this works across multi-line comments.
```@(freeform)
@(coll :gap 0)@notcomment@{comment /[/][*].%[*][/]/}@(end)@tail
@(output)
@(rep)@notcomment @(end)@tail
@(end)

```

### Regexes in TXR Lisp

Parse regex at run time to abstract syntax:
```\$ txr -p '(regex-parse "a.*b")'
(compound #\a (0+ wild) #\b)

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

```
Search replace with `regsub`.
```\$ txr -p '(regsub #/a+/ "-" "baaaaaad")'
"b-d"

```

## Rename a file↗

TXR works with native paths.
```(rename-path "input.txt" "output.txt")
;; Windows (MinGW based port)
(rename-path "C:\\input.txt" "C:\\output.txt")
;; Unix; Windows (Cygwin port)
(rename-path "/input.txt" "/output.txt"))

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

## Return multiple values↗

TXR functions return material by binding unbound variables. The following function potentially returns three values, which will happen if called with three arguments, each of which is an unbound variable:
```@(define func (x y z))
@  (bind (x y z) ("a" "b" "c"))
@(end)

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

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

```
Successful call binding only one new variable:
```@(func "a" "b" s)

```

## Reverse words in a string↗

Run from command line:
```txr reverse.txr verse.txt

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

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

```
not
```@(end)[EOF]

```

## Rot-13↗

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

```
Via TXR Lisp:
```(defun rot13 (ch)
(cond
((<= #\A ch #\Z) (wrap #\A #\Z (+ ch 13)))
((<= #\a ch #\z) (wrap #\a #\z (+ ch 13)))
(t ch)))

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

```

## Runtime evaluation/In an environment↗

### Translation of Common Lisp

In TXR's embedded Lisp dialect, we can implement the same solution as Lisp or Scheme: transform the code fragment by wrapping a `let` around it which binds a variable, and then evaluating the whole thing:
```(defun eval-subtract-for-two-values-of-x (code-fragment x1 x0)
(- (eval ^(let ((x ,x1)) ,code-fragment))
(eval ^(let ((x ,x0)) ,code-fragment))))

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

```
Cutting edge TXR code provides access to the environment manipulation functions, making this possible:
```(defun eval-subtract-for-two-values-of-x (code-fragment x1 x0)
(let ((e1 (make-env (list (cons 'x x1))))   ;; create two environments stuffed with binding for x
(e0 (make-env (list (cons 'x x0)))))
(- (eval code-fragment e1)                ;; pass these environment to eval
(eval code-fragment e0))))

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

```
Alternatively, empty environments can be made and extended with bindings:
```(defun eval-subtract-for-two-values-of-x (code-fragment x1 x0)
(let ((e1 (make-env))
(e0 (make-env)))
(env-vbind e1 'x x1)
(env-vbind e0 'x x0)
(- (eval code-fragment e1)
(eval code-fragment e0))))

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

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

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

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

```

## S-expressions↗

TXR is in the Lisp family, and uses S-Expressions. So right from the system prompt we can do:
```\$ txr -p '(read)'
((data "quoted data" 123 4.5)
(data (!@# (4.5) "(more" "data)")))
[Ctrl-D][Enter]
((data "quoted data" 123 4.5) (data (! (sys:var #(4.5)) "(more" "data)")))
```
However, note that the `@` character has a special meaning: `@obj` turns into `(sys:var obj)`. The purpose of this notation is to support Lisp code that requires meta-variables and meta-expressions. This can be used, for instance, in pattern matching to distinguish binding variables and matching operations from literal syntax. The following solution avoids "cheating" in this way with the built-in parser; it implements a from-scratch S-exp parser which treats `!@#` as just a symbol. The grammar is roughly as follows:
```
expr := ws? atom
|  ws? ( ws? expr* ws? )

atom := float | int | sym | str

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

int := sign? digit+

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

sym := sym-char +

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

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

```
TODO: Note that the recognizer for string literals does not actually process the interior escape sequences `\"`; these remain as part of the string data. The only processing is the stripping of the outer quotes from the lexeme. Explanation of most confusing line:
```    @/\s*\(\s*/@(coll :vars (e))@(expr e)@/\s*/@(last))@(end)

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

## Scope modifiers↗

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

```
Result (with `-B` option to dump bindings):
```a="a"
b="b"
```
By contrast, in this version, the block fails. Because it is contained in a `@(maybe)`, evaluation can proceed, but the binding for `a` is gone.
```@(maybe)@# perhaps this subclause suceeds or not
@  (block foo)
@  (bind a "a")
@  (fail foo)
@(end)
@(bind b "b")

```
Result (with `-B`):
```b="b"
```

## Send email↗

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

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

## Set consolidation↗

Original solution:
```(defun mkset (p x) (set [p x] (or [p x] x)))

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

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

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

;; tests

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

```
##### Output:
```((a b) (c d)) -> ((b a) (d c))
((a b) (b d)) -> ((b a d))
((a b) (c d) (d b)) -> ((b a d c))
((h i k) (a b) (c d) (d b) (f g h)) -> ((g f k i h) (b a d c)
```

### Translation of Racket

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

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

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

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

```
##### Output:
```((a b) (c d)) -> ((b a) (d c))
((a b) (b d)) -> ((d b a))
((a b) (c d) (d b)) -> ((d c b a))
((h i k) (a b) (c d) (d b) (f g h)) -> ((g f k i h) (d c b a))
```

## Shell one-liner↗

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

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

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

```

## Short-circuit evaluation↗

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

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

## Sleep↗

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

```

## Sockets↗

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

```

## Sort stability↗

Straight from the TXR documentation about the `sort` function: The `sort` function is stable for sequences which are lists. This means that the original order of items which are considered identical is preserved. For strings and vectors, `sort` is not stable.

## Soundex↗

#### TXR Pattern Language

This implements the full Soundex described in U.S. National Archives Website . Doubled letters are condensed before separating the first letter, so that for instance "Lloyd" is not treated as L followed by the coding of LOYD but as L followed by the coding of OYD. Consecutive consonants which map to the same code are not condensed to a single occurrence of the code if they are separated by vowels, but separating W and H do not thus intervene. Names with common prefixes are encoded in two ways.
```@(next :args)
@###
@# soundex-related filters
@###
@(deffilter remdbl ("AA" "A") ("BB" "B") ("CC" "C") ("DD" "D") ("EE" "E")
("FF" "F") ("GG" "G") ("HH" "H") ("II" "I") ("JJ" "J")
("KK" "K") ("LL" "L") ("MM" "M") ("NN" "N") ("OO" "O")
("PP" "P") ("QQ" "Q") ("RR" "R") ("SS" "S") ("TT" "T")
("UU" "U") ("VV" "V") ("WW" "W") ("XX" "X") ("YY" "Y")
("ZZ" "Z"))
@(deffilter code ("B" "F" "P" "V" "1")
("C" "G" "J" "K" "Q" "S" "X" "Z" "2")
("D" "T" "3") ("L" "4") ("M" "N" "5")
("R" "6") ("A" "E" "I" "O" "U" "Y" "0") ("H" "W" ""))
@(deffilter squeeze ("11" "111" "1111" "11111" "1")
("22" "222" "2222" "22222" "2")
("33" "333" "3333" "33333" "3")
("44" "444" "4444" "44444" "4")
("55" "555" "5555" "55555" "5")
("66" "666" "6666" "66666" "6"))
@(bind prefix ("VAN" "CON" "DE" "DI" "LA" "LE"))
@(deffilter remzero ("0" ""))
@###
@# soundex function
@###
@(define soundex (in out))
@  (local nodouble letters remainder first rest coded)
@  (next :string in)
@  (coll)@{letters /[A-Za-z]+/}@(end)
@  (cat letters "")
@  (output :into nodouble :filter (:upcase remdbl))
@letters
@  (end)
@  (next :list nodouble)
@  (maybe)
@prefix@remainder
@    (output :into nodouble)
@nodouble
@remainder
@    (end)
@  (end)
@  (next :list nodouble)
@  (collect)
@{first 1}@rest
@    (output :filter (code squeeze remzero) :into coded)
@{rest}000
@    (end)
@    (next :list coded)
@{digits 3}@(skip)
@  (end)
@  (output :into out)
@    (rep):@first@digits@(first)@first@digits@(end)
@  (end)
@  (cat out)
@(end)
@###
@# process arguments and list soundex codes
@###
@(collect :vars ())
@input
@  (output :filter (:fun soundex))
@input
@  (end)
@(end)
@###
@# compare first and second argument under soundex
@###
@(bind (first_arg second_arg . rest_args) input)
@(cases)
@  (bind first_arg second_arg :filter (:fun soundex))
@  (output)
"@first_arg" and "@second_arg" match under soundex
@  (end)
@(end)

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

#### With TXR Lisp

This solution is similar to some of the solutions in other languages. Its treatment of the algorithm is not as complete as the above solution.
```@(do (defun get-code (c)
(caseq c
((#\B #\F #\P #\V) #\1)
((#\C #\G #\J #\K #\Q #\S #\X #\Z) #\2)
((#\D #\T) #\3)
(#\L #\4)
((#\M #\N) #\5)
(#\R #\6)))

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

```
Run:
```\$ ./txr soundex-lisp.txr  soundex sowndex
soundex -> S532
sowndex -> S532
```

## Special characters↗

Text not containing the character `@` is a TXR query representing a match that text. The sequence `@@` encodes a single literal `@`. All other special syntax is introduced by @:
• `@`# comment
• `@\n` # escaped character, embedded into surrounding text. Similar to C escapes, with `\e` for ASCII ESC.
• `@\x1234 @\1234` Hex or octal escapes: Unicode width, not byte.
• `@symbol` variable ref
• `@*symbol` variable ref with longest match semantics
• `@{symbol expr ...}` variable ref extended syntax
• `@expr` directive
Where expr is Lispy syntax which can be an atom, or a list of atoms or lists in parentheses, or possibly a dotted list (terminated by an atom other than nil):
• `(elem1 elem2 ... elemn)` proper
• `(elem1 elem2 ... elemn . atom)` dotted
Atoms can be:
• `ABc123_4` symbols, represented by tokens consisting of letters, underscores and digits, beginning with a letter. Symbols have packages, e.g., system:foo, but this is not accessible from the TXR lexical conventions.
• `:FoO42` keyword symbols, denoted by colon, which is not part of the symbol name.
• `"string literals"`
• ``quasi @literals`` with embedded @ syntax
• `'c'` characters
• `123` integers
• `/reg/` regular expressions
Within literals and regexes:
• `\r` various backslash escapes similar to C
• `\\` single backslash
Within literals, quasiliterals and character constants:
• `\' \" \`` escape any of the quotes: not available within regex.
The regex syntax is fairly standard fare, with these extensions:
• `~R` complement of R: set of strings other than those that match R
• `R%S` match shortest number of repetitions of R prior to S.
• `R&S` match R and S simultaneously: the intersection of the set of strings matching S and the set matching R.
• `[]` empty class; match nothing, not even the empty string.

## String matching↗

### TXR Lisp

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

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

### Pattern Language

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

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

## Strip a set of characters from a string↗

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

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

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

```
##### Output:
```\$ txr strip-chars-2.tl
usage: txr strip-chars-2.tl <string> <set>
\$ txr strip-chars-2.tl "she was a soul stripper. she stole my heart." "aei"
sh ws  soul strppr. sh stol my hrt.
```
Now here is a rewrite of `strip-chars` which just uses classic Lisp that has been generalized to work over strings, plus the `do` syntax (a sibling of the `op` operator) that provides syntactic sugar for a lambda function whose body is an operator or macro form.
```(defun strip-chars (str set)
(mappend (do if (memq @1 set) (list @1)) str))

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

## Strip control codes and extended characters from a string↗

### Translation of Racket

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

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

```

## Strip whitespace from a string/Top and tail↗

### Pattern Matching Language Exercise

Here, no builtin functions are used, just text pattern matching logic. Two functions are written, conforming to the proper filter convention, and then employed as filters.
```@(define trim_left (in out))
@  (next :list in)
@/[ \t]*/@out
@(end)
@(define trim_right (in out))
@  (local blanks middle)
@  (next :list in)
@  (cases)
@    {blanks /[ \t]*/}@middle@/[\t ]+/
@    (bind out `@blanks@middle`)
@  (or)
@    out
@  (end)
@(end)
@line_of_input
@(output)
trim-left:  [@{line_of_input :filter (:fun trim_left)}]
trim_right: [@{line_of_input :filter (:fun trim_right)}]
trim_both:  [@{line_of_input :filter ((:fun trim_left) (:fun trim_right))}]
@(end)

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

### Using Lisp Primitives

Trimming whitespace from both ends is a builtin:
```\$ txr -p '(trim-str " a b ")'
"a b"

```
An unnecessarily cryptic, though educational, left trim:
```\$ txr -p '[(do progn (del [@1 0..(match-regex @1 #/\s*/)]) @1) " a b "]'
"a b "

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

```
Output:
```{ a a}
{}
{a}
{}
```

## Sum of a series↗

Reduce with + operator over a lazily generated list. Variant A1: limit the list generation inside the `gen` operator.
```txr -p '[reduce-left + (let ((i 0)) (gen (< i 1000) (/ 1.0 (* (inc i) i)))) 0]'
1.64393456668156

```
Variant A2: generate infinite list, but take only the first 1000 items using `[list-expr 0..999]`.
```txr -p '[reduce-left + [(let ((i 0)) (gen t (/ 1.0 (* (inc i) i)))) 0..999] 0]'
1.64393456668156

```
Variant B: generate lazy integer range, and pump it through a series of function with the help of the `chain` functional combinator and the `op` partial evaluation/binding operator.
```txr -p '[[chain range (op mapcar (op / 1.0 (* @1 @1))) (op reduce-left + @1 0)] 1 1000]'
1.64393456668156

```
Variant C: unravel the chain in Variant B using straightforward nesting.
```txr -p '[reduce-left + (mapcar (op / 1.0 (* @1 @1)) (range 1 1000)) 0]'
1.64393456668156

```
Variant D: bring Variant B's inverse square calculation into the fold, eliminating mapcar. Final answer.
```txr -p '[reduce-left (op + @1 (/ 1.0 (* @2 @2))) (range 1 1000) 0]'
1.64393456668156

```

## Summarize and say sequence↗

### Translation of Clojure

This is a close, almost expression-by-expression transliteration of the Clojure version.
```;; Syntactic sugar for calling reduce-left
(defmacro reduce-with ((acc init item sequence) . body)
^(reduce-left (lambda (,acc ,item) ,*body) ,sequence ,init))

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

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

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

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

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

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

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

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

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

```
##### Output:
```\$ txr self-ref-seq.tl

Seed value(s): 9900 9090 9009

Iterations: 21

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

### Translation of Common Lisp

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

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

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

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

### Translation of Racket

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

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

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

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

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

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

## Synchronous concurrency↗

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

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

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

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

```

```;;; Type definitions and constants

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

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

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

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

;;; Various constants

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

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

;;; Foreign Function Bindings

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

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

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

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

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

## Text processing/Max licenses in use↗

Working with Version 266.
```
@(bind *times* #H((:eql-based) nil))
@(collect)
License @statuses @@ @dateTimes for job @jobNumbers
@(end)
@(do (each ((status statuses)
(dateTime dateTimes)
(jobNumber jobNumbers))
(if (equal status "OUT")
(progn
@(output)
Peak time(s): @{(reverse (gethash *times* *maximum-licenses-out*))}
@(end)

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

```

## Tokenize a string↗

Collecting tokens which consist of non-empty sequences of non-commas.
```@(next :list "Hello,How,Are,You,Today")
@(coll)@{token /[^,]+/}@(end)
@(output)
@(rep)@token.@(last)@token@(end)
@(end)

```
Different approach. Collect tokens, each of which is a piece of text which either terminates before a comma, or else extends to the end of the line.
```@(next :list "Hello,How,Are,You,Today")
@(coll)@(maybe)@token,@(or)@token@(end)@(end)
@(output)
@(rep)@token.@(last)@token@(end)
@(end)

```
Using TXR Lisp:
```txr -p '(cat-str (split-str "Hello,How,Are,You,Today" ",") ".")'
Hello.How.Are.You.Today

```

## Top rank per group↗

### Template Output Version

This version massages the data in a way that is suitable for generating the output template-wise with an `@(output)` block. The data is in a file, exactly as given in the problem. Parameter N is accepted from command line.
```@(next :args)
@{n-param}
@(next "top-rank-per-group.dat")
Employee Name,Employee ID,Salary,Department
@(collect :vars (record))
@name,@id,@salary,@dept
@(bind record (@(int-str salary) dept name id))
@(end)
@(bind (dept salary dept2 name id)
@(let* ((n (int-str n-param))
(dept-hash [group-by second record :equal-based])
(dept (hash-keys dept-hash))
(ranked (collect-each ((rec (hash-values dept-hash)))
[apply mapcar list [[sort rec > first] 0..n]])))
(cons dept [apply mapcar list ranked])))
@(output)
@  (repeat)
Department: @dept
@    (repeat)
@{name 15} (@id)  \$@{salary -6}
@    (end)
@  (end)
@(end)

```
##### Output:
```Department: D101
George Woltman  (E00127)  \$ 53500
David McClellan (E04242)  \$ 41500
Tyler Bennett   (E10297)  \$ 32000
Department: D202
Rich Holcomb    (E01234)  \$ 49500
Claire Buckman  (E39876)  \$ 27800
David Motsinger (E27002)  \$ 19250
Department: D050
John Rappl      (E21437)  \$ 47000
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")

```
```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 15} (@{r})  \$@{r -6}`)))))

```

## Twelve statements↗

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

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

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

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

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

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

## Unicode strings↗

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

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

```
Expected output (with `txr -B`):
```TITLE="春が来た"
ROMAJI="Haru-ga Kita"
ENGLISH="Spring has Come"
STANZA="春が来た"
STANZA="春が来た"
STANZA="どこに来た"
STANZA="山に来た"
STANZA="里に来た"
STANZA="野にも来た"
STANZA="花が咲く"
STANZA="花が咲く"
STANZA="どこに咲く"
STANZA="山に咲く"
STANZA="里に咲く"
STANZA="野にも咲く"
STANZA="鳥がなく"
STANZA="鳥がなく"
STANZA="どこでなく"
STANZA="山でなく"
STANZA="里でなく"
STANZA="野でもなく"

```

## Update a configuration file↗

This is a general solution which implements a command-line tool for updating the config file. Omitted are the trivial steps for writing the configuration back into the same file; the final result is output on standard output. The first argument is the name of the config file. The remaining arguments are of this form:
```  VAR      # define or update VAR as a true-valued boolean
VAR=     # ensure "; VAR" in the config file.
VAR=VAL  # ensure "VAR VAL" in the config file
```
This works by reading the configuration into a variable, and then making multiple passes over it, using the same constructs that normally operate on files or pipes. The first 30% of the script deals with reading the configuration file and parsing each command line argument, and converting its syntax into configuration syntax, stored in `new_opt_line`. For each argument, the configuration is then scanned and filtered from `config` to `new_config`, using the same syntax which could be used to do the same job with temporary files. When the interesting variable is encountered in the config, using one of the applicable pattern matches, then the prepared configuration line is substituted for it. While this is going on, the encountered variable names (bindings for `var_other`) are also being collected into a list. This list is then later used to check via the directive `@(bind opt_there option)` to determine whether the option occurred in the configuration or not. The bind construct will not only check whether the left and right hand side are equal, but if nested lists are involved, it checks whether either side occurs in the other as a subtree. `option` binds with `opt_other` if it matches one of the option names in `opt_other`. Finally, the updated config is regurgitated.
```@(next :args)
@configfile
@(maybe)
@  (next configfile)
@  (collect :vars (config))
@config
@  (end)
@(end)
@(collect)
@  (cases)
@option=
@    (output :into new_opt_line :filter :upcase)
; @option
@    (end)
@  (or)
@option=@val
@    (output :into new_opt_line :filter :upcase)
@option @val
@    (end)
@  (or)
@option
@    (output :into new_opt_line :filter :upcase)
@option
@    (end)
@  (end)
@  (next :var config)
@  (local new_config)
@  (bind new_config ())
@  (collect :vars ((opt_there "")))
@  (block)
@    (cases)
@      (cases)
@{line /[ \t]*/}
@      (or)
@{line /#.*/}
@      (end)
@      (output :append :into new_config)
@line
@      (end)
@      (accept)
@    (or)
@      (maybe)
; @opt_there
@      (or)
@opt_there @(skip)
@      (or)
@opt_there
@      (or)
@original_line
@      (end)
@    (end)
@    (cases)
@      (bind opt_there option :filter :upcase)
@      (output :append :into new_config)
@new_opt_line
@      (end)
@    (or)
@      (output :append :into new_config)
@original_line
@      (end)
@    (end)
@  (end)
@  (cases)
@    (bind opt_there option :filter :upcase)
@  (or)
@    (output :append :into new_config)
@new_opt_line
@    (end)
@  (end)
@  (set config new_config)
@(end)
@(output)
@  (repeat)
@config
@  (end)
@(end)

```
Sample invocation:
```\$ txr configfile2.txr configfile NEEDSPEELING= seedsREMOVED NUMBEROFBANANAS=1024 NUMBEROFSTRAWBERRIES=62000
# This is a configuration file in standard configuration file format
#
# Lines begininning with a hash or a semicolon are ignored by the application
# program. Blank lines are also ignored by the application program.

# The first word on each non comment line is the configuration option.
# Remaining words or numbers on the line are configuration parameter
# data fields.

# Note that configuration option names are not case sensitive. However,
# configuration parameter data is case sensitive and the lettercase must
# be preserved.

# This is a favourite fruit
FAVOURITEFRUIT banana

# This is a boolean that should be set
; NEEDSPEELING

# This boolean is commented out
SEEDSREMOVED

# How many bananas we have
NUMBEROFBANANAS 1024
NUMBEROFSTRAWBERRIES 62000
```
Test run on empty input:
```\$ echo -n | txr configfile2.txr - NEEDSPEELING= SEEDSREMOVED NUMBEROFBANANAS=1024 NUMBEROFSTRAWBERRIES=62000
; NEEDSPEELING
SEEDSREMOVED
NUMBEROFBANANAS 1024
NUMBEROFSTRAWBERRIES 62000
```
Test run on empty input with no arguments
```\$ echo -n | txr configfile2.txr -
[ no output ]
```

## Use another language to call a function↗

This is really two tasks: how to accept foreign callbacks, and how to link code to a C program which controls the `main` startup function. The TXR run-time is not available as a library that can be linked to a C program. Instead, we can put the C driver into a small library and call out to it from TXR, then accept its callback. Here is that library:
```#include <stdio.h>

int query(int (*callback)(char *, size_t *))
{
char buffer;
size_t size = sizeof buffer;

if (callback(buffer, &size) == 0) {
puts("query: callback failed");
} else {
char *ptr = buffer;

while (size-- > 0)
putchar (*ptr++);
putchar('\n');
}
}

```
Here are the build steps to produce a `query.so` object from it on GNU/Linux:
```gcc -g -fPIC query.c -c
gcc -g --shared query.c -o query.c

```

### Using `carray`

In this situation, the most appropriate FFI type to use for the foreign buffer is the `carray` type. This type allows TXR Lisp code to manipulate a foreign array while retaining its identity, so that it is able to pass the same pointer to the foreign code that it received from that code. `carray` also solves the problem of dealing with the common representational approach in C when arrays are represented by pointers, and do not include their size as part of their type information. A `carray` object can be constructed with an zero size, which can be adjusted when the size is known, using `carray-set-length`. Like the `array` type, `carray` has specialized behaviors when its element type is `char`, `bchar` or `wchar`. The `carray-get` function will decode a string from the underlying array, and `carray-put` will encode a string into the array. In the case of the `char` type, this involves UTF-8 coding. Callbacks are modeled as "FFI closures". The macro `deffi-cb` defines a function which itself isn't a callback, but is rather a combinator which converts a Lisp function into a FFI callback.
```(with-dyn-lib "./query.so"
(deffi query "query" void (closure)))

(deffi-cb query-cb int ((carray char) (ptr (array 1 size-t))))

(query (query-cb (lambda (buf sizeptr)
(symacrolet ((size [sizeptr 0]))
(let* ((s "Here am I")
(l (length s)))
(cond
((> l size) 0)
(t (carray-set-length buf size)
(carray-put buf s)
(set size l))))))))

```
##### Output:
```Here am I
```
Note that the obvious way of passing a `size_t` value by pointer, namely `(ptr size-t)` doesn't work. While the callback will receive the size (FFI will decode the pointer type's semantics and get the size value), updating the size will not propagate back to the caller, because it becomes, effectively, a by-value parameter. A `(ptr size-t)` object has to be embedded in an aggregate that is passed by reference, in order to have two-way semantics. Here we use the trick of treating the `size_t *` as an array of 1, which it de facto is. In the callback, we establish local symbol macro which lets us just refer to `[sizeptr 0]` it as `size`.

### Using `cptr` and `memcpy`

An alternative approach is possible if we avail ourselves of the `memcpy` function via FFI. We can receive the data as an opaque foreign pointer represented by the `cptr` type. We can set up `memcpy` so that its destination argument and return value is a `cptr`, but the source argument is a string:
```(with-dyn-lib "./query.so"
(deffi query "query" void (closure)))

(with-dyn-lib nil
(deffi memcpy "memcpy" cptr (cptr str size-t)))

(deffi-cb query-cb int (cptr (ptr (array 1 size-t))))

(query (query-cb (lambda (buf sizeptr)              ;  int lambda(void *buf, siz
(symacrolet ((size [sizeptr 0])) ;  { #define size sizeptr
(let* ((s "Here am I")         ;    char *s = "Here am I";
(l (length s)))         ;    size_t l = strlen(s);
(cond                        ;    if (length > size)
((> l size) 0)             ;    { return 0; } else
(t (memcpy buf s l)        ;    { memcpy(buf, s, l);
(set size l))))))))     ;      return size = l; } }

```
Here, the use of the `str` type in the `memcpy` interface means that FFI automatically produces a UTF-8 encoding of the string in a temporary buffer. The pointer to that temporary buffer is what is passed into `memcpy`. The temporary buffer is released after `memcpy` returns. To reveal the similarity between the Lisp logic and how a C function might be written, the corresponding C code is shown. However, that C code's semantics is, of course, devoid of any hidden UTF-8 conversion.

### Exceptions from Callback

If the callback throws an exception or performs any other non-local return, it will return a default return value of all zero bits in the given return type. This value can be specified, but the zero default suits our particular situation, because the problem task defines the return value of zero as an error indicator. We can explore this interactively:
```\$ txr
This is the TXR Lisp interactive listener of TXR 177.
Use the :quit command or type Ctrl-D on empty line to exit.
1> (with-dyn-lib "./query.so" (deffi query "query" void (closure)))
#:lib-0177
2> (deffi-cb query-cb int ((ptr (array 1024 char)) (ptr size-t)))
query-cb
3> (query (query-cb (lambda (x y) (error "oops"))))
query: callback failed
** oops
** during evaluation at expr-3:1 of form (error "oops")
4>
```
Here we can see that when the callback throws the `error` exception, the C code prints `query: callback failed`, due to receiving the default abort return value of zero. Then, the exception continues up to the interactive prompt. If a return value other than zero indicates that the callback failed, that can be arranged with an additional argument in `deffi-cb`:
```(deffi-cb query-cb int (cptr (ptr (array 1 size-t))) -1)

```
Now the `query-cb` function generates callbacks that return -1 to the caller, rather than zero, if aborted by a non-local control transfer such as an exception.

## Variable size/Get↗

### Lisp Object Size

All Lisp values are pointer-sized cells, so they have a basic size that is four or eight bytes, depending on whether the processor architecture is 32 or 64 bits. Heap values take up a four-cell record. And some objects have additional dynamically allocated memory. The `prof` operator can be wrapped around code which constructs and returns an object to calculate the size of the heap part plus dynamically allocated memory:
```1> (prof 1)
(1 0 0 0)
```
The first element is the value itself; the remaining values are dynamic memory from `malloc`, Lisp heap memory and execution time. Here, no memory is attributed to the 1. It takes up a four byte pointer on this system, but that isn't counted.
```2> (list 1 2 3)
((1 2 3) 0 48 0)
```
The list object requires three cons cells at 16 (4x4) bytes each.
```3> (prof (copy "foobar"))
("foobar" 28 16 0)
```
The `"foobar"` string requires 28 bytes of `malloc` memory (7 wide characters including a terminating null). The heap entry takes 16 bytes. **Note:** the `pprof` macro ("pretty prof") will gather and print these values in a nice way on the `*stdout*` stream:
```2> (pprof (copy "foobar"))
malloc bytes:            28
gc heap bytes:           16
total:                   44
milliseconds:             0
"foobar"
```

### FFI

In the FFI type system, the `sizeof` macro operator reports size of types.
```1> (sizeof uchar)
1
2> (sizeof (array 3 char))
3
3> (sizeof (struct foo (x (bit 17 uint32))
(y (bit 3 uint8))
(z (array 16 char))))
20
4> (sizeof double)
8
20
```
The `struct` size corresponds to the size of the C struct
```struct foo {
uint32_t x : 17;
uint8_t y : 3;
char z;
};

```
as calculated by the GNU C compiler on the same platform. The `uint32_t` leading bitfield creates a minimum alignment of four bytes. The `y` bitfield is packed into the third byte of the structure, and the `z` array starts on the fourth, ending on the nineteenth. The alignment requirement pads the structure to 20. We can influence the alignment with the `align` type constructor:
```6> (sizeof (struct foo (x (align 1 (bit 17 uint32)))
(y (bit 3 uint8))
(z (array 16 char))))
19
```
The leading bitfield is now deemed to be byte aligned, so the structure is no longer padded for the sake of its alignment.

### Variable Size

Since the task is worded as being about variables rather than objects, what we can do is explore the memory costs of a lexical environment. An empty environment takes up a 16 byte heap record:
```1> (prof (let ()))
(nil 0 16 0)
```
Adding a variable to the environment brings in an additional 32 bytes:
```2> (prof (let (a)))
(nil 0 48 0)
```

## Variable size/Set↗

This task has many possible interpretations in many contexts. For instance, there is a buffer type. When we create a buffer, we specify its length. Optionally, we can also specify how much storage is actually allocated. This will prevent re-allocations if the length is increased within that limit. Here, the buffer holds eight zero bytes, but 4096 bytes is allocated to it:
```(make-buf 8 0 4096)

```
Another situation, in the context of FFI, is that some structure needs to achieve some size, but we don't care about all of its members. We can add anonymous padding to ensure that it meets the minimum size. For instance, suppose we want to call `uname`, and we only care about retrieving the `sysname`:
```1> (with-dyn-lib nil
(deffi uname "uname" int ((ptr-out (struct utsname
(sysname (zarray 65 char))
(nil (array 512 uint)))))))
** warning: (expr-1:2) defun: redefining uname, which is a built-in defun
#:lib-0172
2> (defvar u (new utsname))
u
3> (uname u)
0
4> u
#S(utsname sysname "Linux" nodename nil release nil version nil machine nil
domainname nil)
```
We have specified a FFI definition for `utsname` which lays down the `sysname` member to the correct system-specific array size, and then a generous amount of padding: 512 unsigned integers. Anonymous padding can be specified anywhere in a FFI structure by using the slot name `nil`. The corresponding space will be reserved in the structure using the type of that slot, but the slot will not participate in any data conversions. FFI will not fill in that area of the structure when preparing data, and will not extract anything from that area in the reverse direction. The padding prevents the `uname` function from accessing beyond the end of the memory that is passed to it. We can, of course, determine the exact size of `struct utsname` we can specify the padding such that we know for certain that it meets or exceeds the requirement.

## Variable-length quantity↗

TXR's `carray` type, closely associated with the Foreign Function Interface, has functions for converting between integers and foreign arrays. The arrays can use any element type. The integer is stored in big endian order, and "right justified" within the buffer, so that its least significant byte is aligned with the least significant byte of the last element of the array. Two representations are supported: unsigned and signed. The unsigned representation takes only non-negative integers. It is a straightforward pure binary enumeration. The signed representation uses twos complement. The most significant byte of the array representation is in the range 80-FF if the value is negative, otherwise in the range 0 to 7F. This means that in some cases, a zero byte has to be added. Interactive session:
```1> (carray-num #x200000)
#<carray 3 #<ffi-type uchar>>
2> (carray-get *1)
#(32 0 0)
3> (carray-num #x1FFFFF)
#<carray 3 #<ffi-type uchar>>
4> (carray-get *3)
#(31 255 255)
5> (num-carray *1)
2097152
6> (num-carray *3)
2097151
```
Conversion to a `carray` not based on the default `uchar`:
```1> (carray-num #x123456789 (ffi uint32))
#<carray 2 #<ffi-type uint32>>
2> (carray-get *1)
#(16777216 2305246499)
```
This number requires two 32-bit units to store. Because `uint32` is in the native endian, opposite to the big endian storage of the integer, the words come out byte swapped. The `be-uint32` type could be used to change this.

## Variables↗

Variables have a form of pervasive dynamic scope in TXR. Each statement ("directive") of the query inherits the binding environment of the previous, invoking, or surrounding directive, as the case may be. The initial contents of the binding environment may be initialized on the interpreter's command line. The environment isn't simply a global dictionary. Each directive which modifies the environment creates a new version of the environment. When a subquery fails and TXR backtracks to some earlier directive, the original binding environment of that directive is restored, and the binding environment versions generated by backtracked portions of the query turn to garbage. Simple example: the `cases`
```@(cases)
hey @a
how are you
@(or)
hey @b
long time no see
@(end)

```
This directive has two clauses, matching two possible input cases, which have a common first line. The semantics of cases is short-circuiting: the first successful clause causes it to succeed and stop processing subsequent clauses. Suppose that the input matches the second clause. This means that the first clause will also match the first line, thereby establishing a binding for the variable `a`. However, the first clause fails to match on the second line, which means that it fails. The interpreter then moves to the second clause, which is tried at the original input position, under the original binding environment which is devoid of the `a` variable. Whichever clause of the `cases` is successful will pass both its environment modifications and input position increment to the next element of the query. Under some other constructs, environments may be merged:
```@(maybe)
@a bar
@(or)
foo @b
@(end)

```
The `maybe` directive matches multiple clauses such that it succeeds no matter what, even if none of the clauses succeed. Clauses which fail have no effect, but the effects of all successful clauses are merged. This means that if the input which faces the above `maybe` is the line `"foo bar"`, the first clause will match and bind `a` to foo, and the second clause will also match and bind `b` to bar. The interpreter integrates these results together and the environment which emerges has both bindings.

## Vigenère cipher↗

```@(next :args)
@(do
(defun vig-op (plus-or-minus)
(op + #\A [mod [plus-or-minus (- @1 #\A) (- @2 #\A)] 26]))

(defun vig (msg key encrypt)
(mapcar (vig-op [if encrypt + -]) msg (repeat key))))
@(coll)@{key /[A-Za-z]/}@(end)
@(coll)@{msg /[A-Za-z]/}@(end)
@(cat key "")
@(filter :upcase key)
@(cat msg "")
@(filter :upcase msg)
@(bind encoded @(vig msg key t))
@(bind decoded @(vig msg key nil))
@(bind check @(vig encoded key nil))
@(output)
text:  @msg
key:   @key
enc:   @encoded
dec:   @decoded
check: @check
@(end)

```
Here, the TXR pattern language is used to scan letters out of two arguments, and convert them to upper case. The embedded TXR Lisp dialect handles the Vigenère logic, in just a few lines of code. Lisp programmers may do a "double take" at what is going on here: yes `mapcar` can operate on strings and return strings in TXR Lisp. `(repeat key)` produces an infinite lazy list; but that's okay because `mapcar` stops after the shortest input runs out of items. Run:
```\$ txr vigenere.txr 'vigenere cipher' 'Beware the Jabberwock... The jaws that... the claws that catch!'
text:  BEWARETHEJABBERWOCKTHEJAWSTHATTHECLAWSTHATCATCH
key:   VIGENERECIPHER
enc:   WMCEEIKLGRPIFVMEUGXXYILILZXYVBZLRGCEYAIOEKXIZGU
dec:   GWQWEACDCBLUXNWOIYXPQAHSHLPQFLNDRYUWUKEAWCHSNYU
check: BEWARETHEJABBERWOCKTHEJAWSTHATTHECLAWSTHATCATCH
```

## Walk a directory/Non-recursively↗

#### Using `glob`

```(glob "/etc/*.conf")

```
##### Output:
```("/etc/adduser.conf" "/etc/apg.conf" "/etc/blkid.conf" "/etc/brltty.conf"
"/etc/ca-certificates.conf" "/etc/colord.conf" "/etc/ddclient.conf"
"/etc/debconf.conf" "/etc/deluser.conf" "/etc/dnsmasq.conf" "/etc/ffserver.conf"
"/etc/fuse.conf" "/etc/gai.conf" "/etc/hdparm.conf" "/etc/host.conf"
"/etc/kerneloops.conf" "/etc/knockd.conf" "/etc/ld.so.conf" "/etc/lftp.conf"
"/etc/logrotate.conf" "/etc/ltrace.conf" "/etc/mke2fs.conf" "/etc/mtools.conf"
"/etc/netscsid.conf" "/etc/nsswitch.conf" "/etc/ntp.conf" "/etc/pam.conf"
"/etc/pnm2ppa.conf" "/etc/popularity-contest.conf" "/etc/resolv.conf"
"/etc/rsyslog.conf" "/etc/sensors3.conf" "/etc/sysctl.conf" "/etc/ucf.conf"
"/etc/updatedb.conf" "/etc/usb_modeswitch.conf" "/etc/wodim.conf")

```

#### Using `open-directory` and `get-lines`

```(mappend [iff (op ends-with ".conf") list] (get-lines (open-directory "/etc")))

```
##### Output:
```("ddclient.conf" "gai.conf" "ucf.conf" "kernel-img.conf" "ltrace.conf"
"ffserver.conf" "pam.conf" "sysctl.conf" "ld.so.conf" "dnsmasq.conf"
"insserv.conf" "brltty.conf" "deluser.conf" "netscsid.conf" "nsswitch.conf"
"mtools.conf" "wodim.conf" "updatedb.conf" "popularity-contest.conf"
"knockd.conf" "ntp.conf" "sensors3.conf" "resolv.conf" "blkid.conf"
"lftp.conf" "ca-certificates.conf" "usb_modeswitch.conf" "logrotate.conf"
"rsyslog.conf" "pnm2ppa.conf")

```

## Walk a directory/Recursively↗

There is more than one way to do this in TXR. A recursive walk could be coded using `open-directory` and `getline`. Or FFI could be used to gain access to some platform-specific functions like Microsoft's `FindFirstFile` and so forth. TXR wraps and exposes the POSIX `nftw` function, which is demonstrated here. This function encapsulates a tree walk, and uses callbacks to inform the program of visited filesystem tree nodes, and of error situations. We can use a `lambda` for the code walk, or wrap the invocation of `ftw` with a macro which hides the `lambda` syntax. Here we use the `build` macro for procedural list building to gather all of the found paths into a list, which is implicitly returned. The callback is an explicit `lambda`:
```(build (ftw "." (lambda (path type stat level base)
(if (ends-with ".tl" path)

```
##### Output:
```("./tests/016/arith.tl" "./tests/014/dgram-stream.tl" "./tests/014/socket-basic.tl"
"./tests/sock-common.tl" "./tests/012/ifa.tl" "./tests/012/except.tl"
"./tests/012/fini.tl" "./tests/012/oop.tl" "./tests/012/circ.tl"
"./tests/012/cont.tl" "./tests/012/aseq.tl" "./tests/012/quasi.tl"
"./tests/012/struct.tl" "./tests/012/man-or-boy.tl" "./tests/017/glob-carray.tl"
"./tests/017/glob-zarray.tl" "./tests/017/realpath.tl" "./tests/017/qsort.tl"
"./tests/015/split.tl" "./tests/013/maze.tl" "./tests/common.tl"
"./tests/011/special-1.tl" "./share/txr/stdlib/ifa.tl" "./share/txr/stdlib/with-stream.tl"
"./share/txr/stdlib/pmac.tl" "./share/txr/stdlib/except.tl" "./share/txr/stdlib/awk.tl"
"./share/txr/stdlib/package.tl" "./share/txr/stdlib/place.tl"
"./share/txr/stdlib/trace.tl" "./share/txr/stdlib/type.tl" "./share/txr/stdlib/keyparams.tl"
"./share/txr/stdlib/ffi.tl" "./share/txr/stdlib/ver.tl" "./share/txr/stdlib/build.tl"
"./share/txr/stdlib/txr-case.tl" "./share/txr/stdlib/tagbody.tl"
"./share/txr/stdlib/getopts.tl" "./share/txr/stdlib/socket.tl"
"./share/txr/stdlib/struct.tl" "./share/txr/stdlib/getput.tl"
"./share/txr/stdlib/path-test.tl" "./share/txr/stdlib/with-resources.tl"
"./share/txr/stdlib/yield.tl" "./share/txr/stdlib/conv.tl" "./share/txr/stdlib/termios.tl")

```
For a regex pattern we can replace `(endswith ".tl" path)` with something like `(m\$ path #/\.tl/)`. TXR also provides the `fnmatch` function which can be used to match using a file globbing pattern.
```1< (fnmatch "*.tl" "foo.tl")
t
2>< (fnmatch "*.tl" "foo.c")
nil
```
The `type`, `stat`, `level` and `base` callback arguments we are ignoring closely follow those of the POSIX C `nftw` function. `type` is a type code which indicates the kind of item visited: file, directory; `stat` is a Lisp version of `struct stat`, providing various information about the filesystem object: permissions, timestamps, inode number, etc. A nice approach would be to capture a continuation in the callback, and then obtain the walk elements lazily; alas, capturing a continuation from a C library function's callback is not permitted, because the capture would span foreign stack frames.

## Web scraping↗

#### Robust

Large amounts of the document are matched (in fact the entire thing!), rather than blindly looking for some small amount of context. If the web page changes too much, the query will fail to match. TXR will print the word "false" and terminate with a failed exit status. This is preferrable to finding a false positive match and printing a wrong result. (E.g. any random garbage that happened to be in a line of HTML accidentally containing the string UTC).
```@(next @(open-command "wget -c http://tycho.usno.navy.mil/cgi-bin/timer.pl -O - 2> /dev/null"))
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final"//EN>
<html>
<body>
<TITLE>What time is it?</TITLE>
<H2> US Naval Observatory Master Clock Time</H2> <H3><PRE>
@(collect :vars (MO DD HH MM SS (PM "  ") TZ TZNAME))
<BR>@MO. @DD, @HH:@MM:@SS @(maybe)@{PM /PM/} @(end)@TZ@/\t+/@TZNAME
@  (until)
</PRE>@/.*/
@(end)
</PRE></H3><P><A HREF="http://www.usno.navy.mil"> US Naval Observatory</A>

</body></html>
@(output)
@  (repeat)
@MO-@DD @HH:@MM:@SS @PM @TZ
@  (end)
@(end)

```
Sample run:
```\$ txr navytime.txr
Nov-22 22:49:41    UTC
Nov-22 05:49:41 PM EST
Nov-22 04:49:41 PM CST
Nov-22 03:49:41 PM MST
Nov-22 02:49:41 PM PST
Nov-22 01:49:41 PM AKST
Nov-22 12:49:41 PM HAST
```
Get just the UTC time:
```\$ txr -DTZ=UTC navytime.txr
Nov-22 22:50:16    UTC
```

#### Naive

Skip stuff until a line beginning with `<BR>` has some stuff before "UTC", and capture that stuff:
```@(next @(open-command "wget -c http://tycho.usno.navy.mil/cgi-bin/timer.pl -O - 2> /dev/null"))
@(skip)
<BR>@time@\ UTC@(skip)
@(output)
@time
@(end)

```

## Window creation↗

TXR has no library module for connecting to SDL, X11's Xlib, or GTK2. All of these examples are completely self-contained, using the FFI capability in TXR, which can bind to any library whose interface is defined in terms of C functions and types. No C header file is processed, and not a single line of C has to be compiled.

### Translation of C

A wait for a SDL key-up event is added, missing in the C version, so that the window does not just appear and disappear. Note that SDL's header file uses a `enum` for the event constants like `SDL_KEYUP`. But then in `union SD_Event`, the event field declared as `UInt8`. (That's how it appears on my Ubuntu system; newer versions of SDL seems to have switched the type field, and other fields of the event structures, to `UInt32`.) Here, we exploit TXR's capability to define enumerations of specific types: we make the event enumeration based on `uint8`, giving it a `typedef` name, and then use that `typedef` in the `SD_Event` union.
```(defvarl SDL_INIT_VIDEO #x00000020)
(defvarl SDL_SWSURFACE #x00000000)
(defvarl SDL_HWPALETTE #x20000000)

(typedef SDL_Surface (cptr SDL_Surface))

(typedef SDL_EventType (enumed uint8 SDL_EventType
(SDL_KEYUP 3)
(SDL_QUIT 12)))

(typedef SDL_Event (union SD_Event
(type SDL_EventType)

(with-dyn-lib "libSDL.so"
(deffi SDL_Init "SDL_Init" int (uint32))
(deffi SDL_SetVideoMode "SDL_SetVideoMode"
SDL_Surface (int int int uint32))
(deffi SDL_GetError "SDL_GetError" str ())
(deffi SDL_WaitEvent "SDL_WaitEvent" int ((ptr-out SDL_Event)))
(deffi SDL_Quit "SDL_Quit" void ()))

(when (neql 0 (SDL_Init SDL_INIT_VIDEO))
(put-string `unable to initialize SDL: @(SDL_GetError)`)
(exit nil))

(unwind-protect
(progn
(SDL_SetVideoMode 800 600 16 (logior SDL_SWSURFACE SDL_HWPALETTE))
(let ((e (make-union (ffi SDL_Event))))
(until* (memql (union-get e 'type) '(SDL_KEYUP SDL_QUIT))
(SDL_WaitEvent e))))
(SDL_Quit))

```

### Translation of C

One difference between the C original and this one is that the XLib macros for direct structure access, like `DefaultGC`, `DefaultScreen` or `WhitePixel` are not used; rather the correspoding C functions are used via FFI: `XDefaultScreen` and so on. The macro approach can be mimiced in detail, at the cost of a significant increase in verbosity (cloning the full declaration of the `_XDisplay` struct declaration, and reproducing the macros). Also, this uses an enumeration for the events, so when the event type is decoded from the `XEvent` union, it comes out as a Lisp symbol.
```(typedef XID uint32)

(typedef Window XID)

(typedef Drawable XID)

(typedef Display (cptr Display))

(typedef GC (cptr GC))

(typedef XEventType (enum _XEventType
(KeyPress 2)
(Expose 12)))

(typedef XEvent (union _XEvent
(type XEventType)

(defvarl NULL cptr-null)

(with-dyn-lib "libX11.so"
(deffi XOpenDisplay "XOpenDisplay" Display (bstr))
(deffi XCloseDisplay "XCloseDisplay" int (Display))
(deffi XDefaultScreen "XDefaultScreen"  int (Display))
(deffi XRootWindow "XRootWindow" Window (Display int))
(deffi XBlackPixel "XBlackPixel" ulong (Display int))
(deffi XWhitePixel "XWhitePixel" ulong (Display int))
(deffi XCreateSimpleWindow "XCreateSimpleWindow" Window (Display
Window
int int
uint uint uint
ulong ulong))
(deffi XSelectInput "XSelectInput" int (Display Window long))
(deffi XMapWindow "XMapWindow" int (Display Window))
(deffi XNextEvent "XNextEvent" int (Display (ptr-out XEvent)))
(deffi XDefaultGC "XDefaultGC" GC (Display int))
(deffi XFillRectangle "XFillRectangle" int (Display Drawable GC
int int uint uint))
(deffi XDrawString "XDrawString" int (Display Drawable GC
int int bstr int)))

(let* ((msg "Hello, world!")
(d (XOpenDisplay nil)))
(when (equal d NULL)
(put-line "Cannot-open-display" *stderr*)
(exit 1))

(let* ((s (XDefaultScreen d))
(w (XCreateSimpleWindow d (XRootWindow d s) 10 10 100 100 1
(XBlackPixel d s) (XWhitePixel d s))))
(XMapWindow d w)

(while t
(let ((e (make-union (ffi XEvent))))
(XNextEvent d e)
(caseq (union-get e 'type)
(Expose
(XFillRectangle d w (XDefaultGC d s) 20 20 10 10)
(XDrawString d w (XDefaultGC d s) 10 50 msg (length msg)))
(KeyPress (return)))))

(XCloseDisplay d)))

```

### Translation of C

```(typedef GtkObject* (cptr GtkObject))
(typedef GtkWidget* (cptr GtkWidget))

(typedef GtkWidget* (cptr GtkWidget))

(typedef GtkWindowType (enum GtkWindowType
GTK_WINDOW_TOPLEVEL
GTK_WINDOW_POPUP))

(with-dyn-lib "libgtk-x11-2.0.so.0"
(deffi gtk_init "gtk_init" void ((ptr int) (ptr (ptr (zarray str)))))
(deffi gtk_window_new "gtk_window_new" GtkWidget* (GtkWindowType))
(deffi gtk_signal_connect_full "gtk_signal_connect_full"
ulong (GtkObject* str closure closure val closure int int))
(deffi gtk_widget_show "gtk_widget_show" void (GtkWidget*))
(deffi gtk_main "gtk_main" void ())
(deffi-sym gtk_main_quit "gtk_main_quit"))

(defmacro GTK_OBJECT (cptr)
^(cptr-cast 'GtkObject ,cptr))

(defmacro gtk_signal_connect (object name func func-data)
^(gtk_signal_connect_full ,object ,name ,func cptr-null
,func-data cptr-null 0 0))

(gtk_init (length *args*) (vec-list *args*))

(let ((window (gtk_window_new 'GTK_WINDOW_TOPLEVEL)))
(gtk_signal_connect (GTK_OBJECT window) "destroy" gtk_main_quit nil)
(gtk_widget_show window)
(gtk_main))

```

### Win32/Win64

This solution is based on the "Your First Windows Program" example in MSDN. It registers a Window class, creates a Window and runs a Windows message loop against a custom `WndProc` function that is written in Lisp, which handles `WM_QUIT` and `WM_PAINT` events exactly like its C counterpart. All necessary basic types, structures, constants and foreign functions are declared using the TXR FFI language. Note that the `CW_USEDEFAULT` constant in the Windows header files is defined as `0x80000000`. This is out of range of the signed `int` arguments of `CreateWindowEx` with which it is used. Microsoft is relying on an implementation-defined C conversion to turn this value into the most negative `int`. When the original constant was used in the TXR translation, TXR's FFI uncovered this little problem by throwing an exception arising from the out-of-range conversion attempt. The fix is to specify the correct value directly as `#x-80000000`.
```(typedef LRESULT int-ptr-t)
(typedef LPARAM int-ptr-t)
(typedef WPARAM uint-ptr-t)

(typedef UINT uint32)
(typedef LONG int32)
(typedef WORD uint16)
(typedef DWORD uint32)
(typedef LPVOID cptr)
(typedef BOOL (bool int32))
(typedef BYTE uint8)

(typedef HWND (cptr HWND))
(typedef HINSTANCE (cptr HINSTANCE))
(typedef HICON (cptr HICON))
(typedef HCURSOR (cptr HCURSOR))
(typedef HBRUSH (cptr HBRUSH))
(typedef HDC (cptr HDC))

(typedef ATOM WORD)
(typedef LPCTSTR wstr)

(defvarl NULL cptr-null)

(typedef WNDCLASS (struct WNDCLASS
(style UINT)
(lpfnWndProc closure)
(cbClsExtra int)
(cbWndExtra int)
(hInstance HINSTANCE)
(hIcon HICON)
(hCursor HCURSOR)
(hbrBackground HBRUSH)
(lpszClassName LPCTSTR)))

(defmeth WNDCLASS :init (me)
(zero-fill (ffi WNDCLASS) me))

(typedef POINT (struct POINT
(x LONG)
(y LONG)))

(typedef MSG (struct MSG
(hwnd HWND)
(message UINT)
(wParam WPARAM)
(lParam LPARAM)
(time DWORD)
(pt POINT)))

(typedef RECT (struct RECT
(left LONG)
(top LONG)
(right LONG)
(bottom LONG)))

(typedef PAINTSTRUCT (struct PAINTSTRUCT
(hdc HDC)
(fErase BOOL)
(rcPaint RECT)
(fRestore BOOL)
(fIncUpdate BOOL)
(rgbReserved (array 32 BYTE))))

(defvarl CW_USEDEFAULT #x-80000000)
(defvarl WS_OVERLAPPEDWINDOW #x00cf0000)

(defvarl SW_SHOWDEFAULT 5)

(defvarl WM_DESTROY 2)
(defvarl WM_PAINT 15)

(defvarl COLOR_WINDOW 5)

(deffi-cb wndproc-fn LRESULT (HWND UINT LPARAM WPARAM))

(with-dyn-lib "kernel32.dll"
(deffi GetModuleHandle "GetModuleHandleW" HINSTANCE (wstr)))

(with-dyn-lib "user32.dll"
(deffi RegisterClass "RegisterClassW" ATOM ((ptr-in WNDCLASS)))
(deffi CreateWindowEx "CreateWindowExW" HWND (DWORD
LPCTSTR LPCTSTR
DWORD
int int int int
LPVOID))
(deffi ShowWindow "ShowWindow" BOOL (HWND int))
(deffi GetMessage "GetMessageW"  BOOL ((ptr-out MSG) HWND UINT UINT))
(deffi TranslateMessage "TranslateMessage"  BOOL ((ptr-in MSG)))
(deffi DispatchMessage "DispatchMessageW"  LRESULT ((ptr-in MSG)))
(deffi PostQuitMessage "PostQuitMessage" void (int))
(deffi DefWindowProc "DefWindowProcW" LRESULT (HWND UINT LPARAM WPARAM))
(deffi BeginPaint "BeginPaint" HDC (HWND (ptr-out PAINTSTRUCT)))
(deffi EndPaint "EndPaint" BOOL (HWND (ptr-in PAINTSTRUCT)))
(deffi FillRect "FillRect" int (HDC (ptr-in RECT) HBRUSH)))

(defun WindowProc (hwnd uMsg wParam lParam)
(caseql* uMsg
(WM_DESTROY
(PostQuitMessage 0)
0)
(WM_PAINT
(let* ((ps (new PAINTSTRUCT))
(hdc (BeginPaint hwnd ps)))
(FillRect hdc ps.rcPaint (cptr-int (succ COLOR_WINDOW) 'HBRUSH))
(EndPaint hwnd ps)
0))
(t (DefWindowProc hwnd uMsg wParam lParam))))

(let* ((hInstance (GetModuleHandle nil))
(wc (new WNDCLASS
lpfnWndProc [wndproc-fn WindowProc]
hInstance hInstance
lpszClassName "Sample Window Class")))
(RegisterClass wc)
(let ((hwnd (CreateWindowEx 0 wc.lpszClassName "Learn to Program Windows"
WS_OVERLAPPEDWINDOW
CW_USEDEFAULT CW_USEDEFAULT
CW_USEDEFAULT CW_USEDEFAULT
NULL NULL hInstance NULL)))
(unless (equal hwnd NULL)
(ShowWindow hwnd SW_SHOWDEFAULT)

(let ((msg (new MSG)))
(while (GetMessage msg NULL 0 0)
(TranslateMessage msg)
(DispatchMessage msg))))))

```

## Window creation/X11↗

See Window_creation#TXR .

## XML/Input↗

This program shows how most of the information in the XML can be extracted with very little code, which doesn't actually understand XML. The name Émily is properly converted from the HTML/XML escape syntax.
```<Students>
@(collect :vars (NAME GENDER YEAR MONTH DAY (PET_TYPE "none") (PET_NAME "")))
@  (cases)
<Student Name="@NAME" Gender="@GENDER" DateOfBirth="@YEAR-@MONTH-@DAY"@(skip)
@  (or)
<Student DateOfBirth="@YEAR-@MONTH-@DAY" Gender="@GENDER" Name="@NAME"@(skip)
@  (end)
@  (maybe)
<Pet Type="@PET_TYPE" Name="@PET_NAME" />
@  (end)
@(until)
</Students>
@(end)
@(output :filter :from_html)
NAME         G DOB        PET
@  (repeat)
@{NAME 12} @GENDER @YEAR-@MONTH-@DAY @PET_TYPE @PET_NAME
@  (end)
@(end)

```
Sample run:
```\$ txr students.txr students.xml
NAME         G DOB        PET
April        F 1989-01-02 none
Bob          M 1990-03-04 none
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
Dave
Émily
```

## Y combinator↗

This prints out 24, the factorial of 4:
```;; The Y combinator:
(defun y (f)
[(op @1 @1)
(op f (op [@@1 @@1]))])

;; The Y-combinator-based factorial:
(defun fac (f)
(do if (zerop @1)
1
(* @1 [f (- @1 1)])))

;; Test:
(format t "~s\n" [[y fac] 4])

```
Both the `op` and `do` operators are a syntactic sugar for currying, in two different flavors. The forms within `do` that are symbols are evaluated in the normal Lisp-2 style and the first symbol can be an operator. Under `op`, any forms that are symbols are evaluated in the Lisp-2 style, and the first form is expected to evaluate to a function. The name `do` stems from the fact that the operator is used for currying over special forms like `if` in the above example, where there is evaluation control. Operators can have side effects: they can "do" something. Consider `(do set a @1)` which yields a function of one argument which assigns that argument to `a`. The compounded `@@...` notation allows for inner functions to refer to outer parameters, when the notation is nested. Consider
```(op foo @1 (op bar @2 @@2))

```
. Here the `@2` refers to the second argument of the anonymous function denoted by the inner `op`. The `@@2` refers to the second argument of the outer `op`.

## Yahoo! search interface↗

The following gives us a shell utility which we can invoke with arguments like "rosetta 0" to get the first page of search results for "rosetta". The two arguments are handled as if they were two lines of text from a data source using @(next :args). We throw an exception if there is no match (insufficient arguments are supplied). The @(cases) directive has strictly ordered evaluation, so the throw in the second branch does not happen if the first branch has a successful pattern match. If the similar @(maybe) or @(some) directives were used, this wouldn't work. A little sprinkling of regex is used.
```#!/usr/bin/txr -f
@(next :args)
@(cases)
@  QUERY
@  PAGE
@(or)
@  (throw error "specify query and page# (from zero)")
@(end)
@(next (open-command "!wget -O - http://search.yahoo.com/search?p=@QUERY\&b=@{PAGE}1 2> /dev/null"))
@(all)
@  (coll)<a class="yschttl spt" href="@URL" @/[^>]+/>@TITLE</a>@(end)
@(and)
@  (coll)<div class="@/abstr|sm-abs/">@ABSTR</div>@(end)
@(end)
@(output)
@  (repeat)
TITLE: @TITLE
URL: @URL
TEXT: @ABSTR
---
@  (end)
@(end)

```
Sample run:
```\$ ./yahoosearch.txr rosetta 0
TITLE: <b>Rosetta</b> | Partner With Our Interactive <wbr />Marketing Agency Today
URL: http://www.rosetta.com/Pages/default.aspx
TEXT: Learn about the fastest growing interactive marketing agency in the country - <b>Rosetta</b>. Our strategic marketing planning is custom built and connects you with your ...
---
TITLE: Official <b>Rosetta</b> StoneÂ® - Learn a <wbr />Language Online - Language ...
URL: http://www.rosettastone.com/
TEXT: <b>Rosetta</b> Stone is the world&#39;s #1 language-learning software. Our comprehensive foreign language program provides language learning for individuals and language learning ...
---
TITLE: <b>Rosetta</b> (software) - Wikipedia, the <wbr />free encyclopedia
URL: http://en.wikipedia.org/wiki/Rosetta_(software)
TEXT: Rosettais a lightweight dynamic translatorfor Mac OS Xdistributed by Apple. It enabled applications compiled for the PowerPCfamily of processors to run on Apple systems that use...
---
TITLE: <b>Rosetta</b> (spacecraft) - Wikipedia, the <wbr />free encyclopedia
URL: http://en.wikipedia.org/wiki/Rosetta_space_probe
TEXT: Rosettais a robotic spacecraftof the European Space Agencyon a mission to study the comet 67P/ChuryumovâGerasimenko. <b>Rosetta </b>consists of two main elements: the <b>Rosetta </b>space probeand...
---
TITLE: Apple - Mac
URL: http://www.apple.com/mac/
---
TITLE: <b>Rosetta</b> | Free Music, Tour Dates, <wbr />Photos, Videos
URL: http://www.myspace.com/rosetta
TEXT:  <b>Rosetta</b>&#39;s official profile including the latest music, albums, songs, music videos and more updates.
---
TITLE: <b>Rosetta</b>
URL: http://rosettaband.com/
---
TITLE: <b>Rosetta</b>
URL: http://rosetta.jpl.nasa.gov/
TEXT: The <b>Rosetta</b> spacecraft is on its way to catch and land a robot on a comet! <b>Rosetta</b> will reach comet &#39;67P/Churyumov-Gerasimenko&#39; (&#39;C-G&#39;) in 2014. The European Space Agency ...
---
TITLE: <b>Rosetta</b> : Multi-script Typography
URL: http://rosettatype.com/
TEXT: <b>Rosetta</b> is a new independent foundry with a strong focus on multi-script typography. We are committed to promote research and knowledge in that area and to support ...
---
TITLE: <b>Rosetta</b> (1999) - IMDb
URL: http://www.imdb.com/title/tt0200071/
TEXT: With Ãmilie Dequenne, Fabrizio Rongione, Anne Yernaux, Olivier Gourmet. Young and impulsive <b>Rosetta</b> lives with her alcoholic mother and, moved by despair, she will ...
---

```