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)])])))
(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)))
((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])
(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])]))
((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))
$ echo 123-456-7890 | txr -c '@a-@b-@c' -
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 -p '(+ 2 2)'
$ txr -e '(mkdir &foo& #o777)'
$ ls -ld foo
drwxrwxr-x 2 kaz kaz 4096 Mar
4 23:36 foo
@(define a (x out))
a (@x) called
(bind out x)
@(define b (x out))
b (@x) called
(bind out x)
@(define short_circuit_demo (i j))
a(@i) and b(@j):
a(@i) or b(@j):
@(short_circuit_demo &0& &0&)
@(short_circuit_demo &0& &1&)
@(short_circuit_demo &1& &0&)
@(short_circuit_demo &1& &1&)
$ txr short-circuit-bool.txr
a(0) and b(0):
a (0) called
a(0) or b(0):
a (0) called
b (0) called
a(0) and b(1):
a (0) called
a(0) or b(1):
a (0) called
b (1) called
a(1) and b(0):
a (1) called
b (0) called
a(1) or b(0):
a (1) called
a(1) and b(1):
a (1) called
b (1) called
a(1) or b(1):
a (1) called
The a and b functions are defined such that the second parameter is intended to be an unbound variable. When the function binds
out, that value propagates back to the unbound variable at the call site. But the way calls works in this language allows us to specify a value instead such as "1". So now the directive @(bind out x) performs unification instead: if x doesn't match "1", the function fails, otherwise it succeeds.
So simply by placing two calls consecutively, we get a short circuting conjunction. The second will not execute if the first one fails.
Short-circuiting disjunction is provided by @(cases).
The @(maybe) construct stops failure from propagating from the enclosed subquery. The @(accept) directive will bail out of the closest enclosing anonymous block (the function body) with a success. It prevents the @(cases) from failing the function if neither case is successful.
TXR Pattern Language
This implements the full Soundex described in
. 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)
@(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& &&))
@(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))
(next :list nodouble)
@prefix@remainder
(output :into nodouble)
@remainder
(next :list nodouble)
@{first 1}@rest
(output :filter (code squeeze remzero) :into coded)
@{rest}000
(next :list coded)
@{digits 3}@(skip)
(output :into out)
(rep):@first@digits@(first)@first@digits@(end)
@(collect :vars ())
(output :filter (:fun soundex))
@(bind (first_arg second_arg . rest_args) input)
(bind first_arg second_arg :filter (:fun soundex))
&@first_arg& and &@second_arg& match under soundex
$ txr soundex.txr example soundex Lloyd lee guttierez o\'hara vandeusen dimeola
"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)
((#\B #\F #\P #\V) #\1)
((#\C #\G #\J #\K #\Q #\S #\X #\Z) #\2)
((#\D #\T) #\3)
((#\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)
@arg -& @(soundex arg)
$ ./txr soundex-lisp.txr
soundex sowndex
soundex -& S532
sowndex -& S532
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)
(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:
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:
complement of R: set of strings other than those that match R
match shortest number of repetitions of R prior to S.
match R and S simultaneously: the intersection of the set of strings matching S and the set matching R.
[] match nothing, not even the empty string.
(tree-case *args*
((big small)
((& (length big) (length small))
(put-line `@big is shorter than @small`))
((str= big small)
(put-line `@big and @small are equal`))
((match-str big small)
(put-line `@small is a prefix of @big`))
((match-str big small -1)
(put-line `@small is a suffix of @big`))
(t (let ((pos (search-str big small)))
(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&`)))
$ 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
second line is the same as first line
(skip)@line
first line is a suffix of the second line
line@(skip)
first line is a suffix of the second line
prefix@line@(skip)
first line is embedded in the second line at position @(length prefix)
first line is not found in the second line
$ txr cmatch.txr -
first line is embedded in the second line at position 1
$ txr cmatch.txr -
first line is a suffix of the second line
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&`)
(tree-case *args*
((str set extra) (usage))
((str set . junk) (pprinl (strip-chars str set)))
(else (usage)))
$ 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"
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.
Translation of Racket
(defun strip-controls (str)
(regsub #/[\x0-\x1F\x7F]+/ && str))
(defun strip-controls-and-extended (str)
(regsub #/[^\x20-\x7F]+/ && str))
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
@(define trim_right (in out))
(local blanks middle)
(next :list in)
{blanks /[ \t]*/}@middle@/[\t ]+/
(bind out `@blanks@middle`)
@line_of_input
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))}]
$ echo "" | txr trim.txr
trim-left:
trim_right: []
trim_both:
$ echo "a" | txr trim.txr
trim-left:
trim_right: [a]
trim_both:
$ echo " a" | txr trim.txr
trim-left:
trim_right: [ a]
trim_both:
$ echo " a " | txr trim.txr
trim-left:
trim_right: [ a]
trim_both:
$ echo " a b " | txr trim.txr
trim-left:
trim_right: [ a b]
trim_both:
Using Lisp Primitives
Trimming whitespace from both ends is a builtin:
$ txr -p '(trim-str & a b &)'
An unnecessarily cryptic, though educational, left trim:
$ txr -p '[(do progn (del [@1 0..(match-regex @1 #/\s*/)]) @1) & 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)
((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 &&))
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]'
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]'
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]'
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]'
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]'
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 ac 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
(:method resume (self)
[self.cont])
(:method give (self item)
[self.cont item])
(:method get (self)
(yield-from run nil))
(:method start (self)
(set self.cont (obtain self.(run)))
(unless self.suspended
self.(resume)))
(:postinit (self)
self.(start)))
(defstruct consumer thread
(:method run (self)
(whilet ((item self.(get)))
(prinl item)
(inc self.count))))
(defstruct producer thread
(: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}`))
Collecting tokens which consist of non-empty
sequences of non-commas.
@(next :list &Hello,How,Are,You,Today&)
@(coll)@{token /[^,]+/}@(end)
@(rep)@token.@(last)@token@(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)
@(rep)@token.@(last)@token@(end)
Using TXR Lisp:
txr -p '(cat-str (split-str &Hello,How,Are,You,Today& &,&) &.&)'
Hello.How.Are.You.Today
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))
@(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])))
Department: @dept
@{name 15} (@id)
$@{salary -6}
Department: D101
George Woltman
David McClellan (E04242)
Tyler Bennett
Department: D202
Rich Holcomb
Claire Buckman
David Motsinger (E27002)
Department: D050
John Rappl
Nathan Adams
Department: D190
Kim Arlich
Timothy Grove
Breakdown:
Descend into argument list:
@(next :args)
Collect first argument as n-param variable:
@{n-param}
Drill into data file:
@(next &top-rank-per-group.dat&)
Match header exactly:
Employee Name,Employee ID,Salary,Department
Now iterate over the data, requiring a variable called record to be bound in each iteration, and suppress all other variables from emerging.
In the body of the collect, bind four variables. Then use these four variables to create a four-element list which is bound to the variable record. The int-str function converts the textual variable salary to an integer:
@(collect :vars (record))
@name,@id,@salary,@dept
@(bind record (@(int-str salary) dept name id))
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 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:
Department: @dept
@{name 15} (@id)
$@{salary -6}
Here, all these variables are individual lists. The dept var one nesting of @(repeat) iterates over it. The other variab 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))
(let* ((n (int-str n-param))
(dept-hash [group-by second record :equal-based])
(ranked (collect-each ((rec (hash-values dept-hash)))
[[sort rec & first] 0..n])))
(each ((d (hash-keys dept-hash))
(dept-recs ranked))
(put-line `Department: @d`)
(each ((r dept-recs))
(put-line `
@{r[2] 15} (@{r[3]})
$@{r[0] -6}`)))))
(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)
(= (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))))
((zerop wrong-count)
^((:----& ,*(true-indices truths))))
((= 1 wrong-count)
^((:close ,*(true-indices truths) (:wrong ,pos-wrong))))))))
(each ((r results))
(put-line `@r`))
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)
TXR source code and I/O are all assumed to be text which is UTF-8 encoded.
This is a self-contained implementation, not relying on any encoding library.
TXR ignores LANG and such environment variables.
One of the regression test cases uses Japanese text.
Characters can be coded directly, or encoded indirectly with hexadecimal escape sequences.
The regular expression engine, also an original implementation, self-contained within TXR, supports full Unicode (not only the Basic Multilingual Plane, but all planes).
However, as of version 89, identifiers such as variables are restricted to English letters, numbers and underscores.
Whether or not text outside of the Basic Multilingual Plane can actually be represented by a given port of TXR depends on the width of the C compiler's wchar_t type. A 16 bit wchar_t restricts the program to the BMP.
Japanese test case:
@{TITLE /[あ-ん一-耙]+/} (@ROMAJI/@ENGLISH)
@(freeform)
@(coll)@{STANZA /[^\n\x3000 ]+/}@(end)@/.*/
Test data: Japanese traditional song:
春が来た (Haru-ga Kita/Spring has Come)
春が来た　春が来た　どこに来た
山に来た　里に来た　野にも来た
花が咲く　花が咲く　どこに咲く
山に咲く　里に咲く　野にも咲く
鳥がなく　鳥がなく　どこでなく
山でなく　里でなく　野でもなく
Expected output (with txr -B):
TITLE="春が来た"
ROMAJI="Haru-ga Kita"
ENGLISH="Spring has Come"
STANZA[0]="春が来た"
STANZA[1]="春が来た"
STANZA[2]="どこに来た"
STANZA[3]="山に来た"
STANZA[4]="里に来た"
STANZA[5]="野にも来た"
STANZA[6]="花が咲く"
STANZA[7]="花が咲く"
STANZA[8]="どこに咲く"
STANZA[9]="山に咲く"
STANZA[10]="里に咲く"
STANZA[11]="野にも咲く"
STANZA[12]="鳥がなく"
STANZA[13]="鳥がなく"
STANZA[14]="どこでなく"
STANZA[15]="山でなく"
STANZA[16]="里でなく"
STANZA[17]="野でもなく"
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 bac 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:
# define or update VAR as a true-valued boolean
# ensure "; VAR" in the config file.
# 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
(next configfile)
(collect :vars (config))
@(collect)
(output :into new_opt_line :filter :upcase)
@option=@val
(output :into new_opt_line :filter :upcase)
@option @val
(output :into new_opt_line :filter :upcase)
(next :var config)
(local new_config)
(bind new_config ())
(collect :vars ((opt_there &&)))
@{line /[ \t]*/}
@{line /#.*/}
(output :append :into new_config)
; @opt_there
@opt_there @(skip)
@opt_there
@original_line
(bind opt_there option :filter :upcase)
(output :append :into new_config)
@new_opt_line
(output :append :into new_config)
@original_line
(bind opt_there option :filter :upcase)
(output :append :into new_config)
@new_opt_line
(set config new_config)
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 ]
In TXR, the preferred way to render data into octets is to convert it to a character string. Character strings are Unicode, which serializes to UTF-8 when sent to text streams.
(defun put-utf8 (str : stream)
(set stream (or stream *stdout*))
(for ((s (make-string-byte-input-stream str)) byte)
((set byte (get-byte s)))
((format stream &\\x~,02x& byte))))
(put-utf8 (tostring 0))
(put-line &&)
(put-utf8 (tostring 42))
(put-line &&)
(put-utf8 (tostring #x200000))
(put-line &&)
(put-utf8 (tostring #x1fffff))
(put-line &&)
(format t &~a\n& (read (tostring #x200000)))
(format t &~a\n& (read (tostring #x1f0000)))
\x32\x30\x39\x37\x31\x35\x32
\x32\x30\x39\x37\x31\x35\x31
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
how are you
long time no see
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:
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.
@(next :args)
(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))
check: @check
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 a but that's okay because mapcar stops after the shortest input runs out of items.
$ txr vigenere.txr 'vigenere cipher' 'Beware the Jabberwock... The jaws that... the claws that catch!'
BEWARETHEJABBERWOCKTHEJAWSTHATTHECLAWSTHATCATCH
VIGENERECIPHER
WMCEEIKLGRPIFVMEUGXXYILILZXYVBZLRGCEYAIOEKXIZGU
GWQWEACDCBLUXNWOIYXPQAHSHLPQFLNDRYUWUKEAWCHSNYU
check: BEWARETHEJABBERWOCKTHEJAWSTHATTHECLAWSTHATCATCH
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
-O - 2& /dev/null&))
&!DOCTYPE HTML PUBLIC &-//W3C//DTD HTML 3.2 Final&//EN&
&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
&/PRE&@/.*/
&/PRE&&/H3&&P&&A HREF=&&& US Naval Observatory&/A&
&/body&&/html&
@MO-@DD @HH:@MM:@SS @PM @TZ
Sample run:
$ txr navytime.txr
Nov-22 22:49:41
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
Skip stuff until a line beginning with &BR& has some stuff before "UTC", and capture that stuff:
@(next @(open-command &wget -c
-O - 2& /dev/null&))
&BR&@time@\ UTC@(skip)
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 &&)))
&Student Name=&@NAME& Gender=&@GENDER& DateOfBirth=&@YEAR-@MONTH-@DAY&@(skip)
&Student DateOfBirth=&@YEAR-@MONTH-@DAY& Gender=&@GENDER& Name=&@NAME&@(skip)
&Pet Type=&@PET_TYPE& Name=&@PET_NAME& /&
&/Students&
@(output :filter :from_html)
@{NAME 12} @GENDER @YEAR-@MONTH-@DAY @PET_TYPE @PET_NAME
Sample run:
$ txr students.txr students.xml
To obtain the output specified in this task, we can simply reduce the @(output) block to this:
@(output :filter :from_html)
This prints out 24, the factorial of 4:
(defun y (f)
[(op @1 @1)
(op f (op [@@1 @@1]))])
(defun fac (f)
(do if (zerop @1)
(* @1 [f (- @1 1)])))
(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.
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)
(throw error &specify query and page# (from zero)&)
@(next (open-command &!wget -O - \&b=@{PAGE}1 2& /dev/null&))
(coll)&a class=&yschttl spt& href=&@URL& @/[^&]+/&@TITLE&/a&@(end)
(coll)&div class=&@/abstr|sm-abs/&&@ABSTR&/div&@(end)
TITLE: @TITLE
TEXT: @ABSTR
Sample run:
$ ./yahoosearch.txr rosetta 0
TITLE: &b&Rosetta&/b& | Partner With Our Interactive &wbr /&Marketing Agency Today
URL: /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?(R) - Learn a &wbr /&Language Online - Language ...
TEXT: &b&Rosetta&/b& Stone is the world'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: /mac/
TEXT: Discover the world of Mac. Check out MacBook, iMac, iLife, and more. Download QuickTime, Safari, and widgets for free.
TITLE: &b&Rosetta&/b& | Free Music, Tour Dates, &wbr /&Photos, Videos
URL: /rosetta
&b&Rosetta&/b&'s official profile including the latest music, albums, songs, music videos and more updates.
TITLE: &b&Rosetta&/b&
TEXT: Metal for astronauts. Philadelphia, since 2003. Contact us at
Twitter | Facebook
TITLE: &b&Rosetta&/b&
URL: http://rosetta.jpl.nasa.gov/
TEXT: The &b&Rosetta&/b& spacecraft is on its way to catch and land a robot on a comet! &b&Rosetta&/b& will reach comet '67P/Churyumov-Gerasimenko' ('C-G') in 2014. The European Space Agency ...
TITLE: &b&Rosetta&/b& : Multi-script Typography
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: /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 ...}