tag:blogger.com,1999:blog-82881949868202492162019-02-12T22:58:36.165-08:00Abstract HeresiesUnorthodox opinions on computer science and programming.Joe Marshallnoreply@blogger.comBlogger411125tag:blogger.com,1999:blog-8288194986820249216.post-86241544357461461322016-01-30T21:28:00.000-08:002016-01-30T21:28:19.379-08:00Race results are inSome people wanted to compare machines, so here is the exact code I used and some sample values I got from running it on my laptop. I'm curious what values other people get.<br />
<pre>;;; -*- Mode: scheme; coding:us-ascii -*-
;;; This is code for MIT/GNU Scheme. We attempt to measure the speed of ASSQ.
;;; The code avoids obvious abstractions because we don't want to
;;; measure the speed of function calling.
;; Inline the standard scheme primitives.
(declare (usual-integrations))
;; We change the size and alignment of the heap by consing a small
;; data structure to this list.
(define *change-heap-size-and-alignment* '())
;;; Creates a test alist that looks like this:
;;; ((13 . "13")
;;; (23 . "23")
;;; (25 . "25")
;;; (18 . "18")
;;; (0 . "0")
;;; (19 . "19")
;;; (5 . "5")
;;; (4 . "4")
;;; (6 . "6")
;;; ...
;;;
(define (make-test-alist n-elements)
(let ((alist
(fold-left (lambda (alist number)
(alist-cons number (number->string number)
alist))
'()
;; shuffle the numbers from 1 to n
(map car
(sort
(map (lambda (n)
(cons n (random 1.0)))
(iota n-elements))
(lambda (l r) (< (cdr l) (cdr r))))))))
(gc-flip)
(set! *change-heap-size-and-alignment*
(cons (vector #f) *change-heap-size-and-alignment*))
alist))
;;; Creates an alist of <size> entries and then measures the time to
;;; perform n-lookups on it. Specialized to fixnum-only arithmetic.
(define (time-alist size n-lookups)
(let ((test-alist (make-test-alist size)))
(show-time
(lambda ()
(do ((i 0 (fix:+ i 1))
(idx 0 (if (fix:> idx size)
0
(fix:+ idx 1)))
(answer '() (assq idx test-alist)))
((fix:>= i n-lookups) answer))))))
</pre>Here's a sample run on my laptop. We make an alist with 10 elements and call ASSQ 100,000,000 times on it, fetching each entry about the same number of times.<br />
<pre>1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-alist 10 100000000))
;process time: 2260 (2260 RUN + 0 GC); real time: 2259
;process time: 2260 (2260 RUN + 0 GC); real time: 2265
;process time: 2290 (2290 RUN + 0 GC); real time: 2291
;process time: 2250 (2250 RUN + 0 GC); real time: 2247
;process time: 2260 (2260 RUN + 0 GC); real time: 2259
;process time: 2240 (2240 RUN + 0 GC); real time: 2240
;process time: 2240 (2240 RUN + 0 GC); real time: 2243
;process time: 2250 (2250 RUN + 0 GC); real time: 2258
;process time: 2240 (2240 RUN + 0 GC); real time: 2247
;process time: 2250 (2250 RUN + 0 GC); real time: 2250</pre>Process time is reported in milliseconds, so it took about 2.26 seconds to do 100,000,000 million lookups. This divides out to .0000000225 seconds = 22.5 nanoseconds per lookup.<br />
<p>It should be about linear with the size of the list, so we'd expect a 100 element list to take somewhere around 225 nanoseconds.<br />
<pre>1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-alist 100 100000000))
;process time: 20720 (20720 RUN + 0 GC); real time: 20753
;process time: 20700 (20700 RUN + 0 GC); real time: 20733
;process time: 20640 (20640 RUN + 0 GC); real time: 20671
;process time: 20690 (20690 RUN + 0 GC); real time: 20695
;process time: 20670 (20670 RUN + 0 GC); real time: 20690
;process time: 21010 (21010 RUN + 0 GC); real time: 21026
;process time: 20800 (20800 RUN + 0 GC); real time: 20832
;process time: 20760 (20760 RUN + 0 GC); real time: 20747
;process time: 20710 (20710 RUN + 0 GC); real time: 20702
;process time: 20690 (20690 RUN + 0 GC); real time: 20700
;Value: #t
</pre>Testing a hash table:<br />
<pre>(define (make-test-hash-table n-entries)
(alist->hash-table (make-test-alist n-entries)))
;;; Creates a hash-table of <size> entries and then measures the time to
;;; perform n-lookups on it. Specialized to fixnum-only arithmetic.
(define (time-hash-table size n-lookups)
(let ((test-hash-table (make-test-hash-table size)))
(show-time
(lambda ()
(do ((i 0 (fix:+ i 1))
(idx 0 (if (fix:> idx size)
0
(fix:+ idx 1)))
(answer '() (hash-table/get test-hash-table idx #f)))
((fix:>= i n-lookups) answer))))))
</pre>Put 10 elements or a thousand in a hash table, it takes a constant amount of time to look things up:<br />
<pre>1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-hash-table 10 100000000))
;process time: 8320 (8320 RUN + 0 GC); real time: 8321
;process time: 8300 (8300 RUN + 0 GC); real time: 8304
;process time: 8420 (8420 RUN + 0 GC); real time: 8419
;process time: 8280 (8280 RUN + 0 GC); real time: 8304
;process time: 8380 (8380 RUN + 0 GC); real time: 8387
;process time: 8280 (8280 RUN + 0 GC); real time: 8288
;process time: 8320 (8320 RUN + 0 GC); real time: 8311
;process time: 8330 (8330 RUN + 0 GC); real time: 8327
;process time: 8290 (8290 RUN + 0 GC); real time: 8290
;process time: 8310 (8310 RUN + 0 GC); real time: 8307
;Value: #t
1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-hash-table 1000 100000000))
;process time: 8400 (8400 RUN + 0 GC); real time: 8403
;process time: 8550 (8550 RUN + 0 GC); real time: 8553
;process time: 8620 (8620 RUN + 0 GC); real time: 8639
;process time: 8420 (8420 RUN + 0 GC); real time: 8435
;process time: 8400 (8400 RUN + 0 GC); real time: 8425
;process time: 8460 (8460 RUN + 0 GC); real time: 8455
;process time: 8460 (8460 RUN + 0 GC); real time: 8459
;process time: 8480 (8480 RUN + 0 GC); real time: 8486
;process time: 8500 (8500 RUN + 0 GC); real time: 8502
;process time: 8520 (8520 RUN + 0 GC); real time: 8518
;Value: #t
</pre>Testing an rb-tree:<br />
<pre>(define (make-test-rb-tree n-entries)
(alist->rb-tree (make-test-alist n-entries) fix:= fix:<))
;;; Creates a rb-tree of <size> entries and then measures the time to
;;; perform n-lookups on it. Specialized to fixnum-only arithmetic.
(define (time-rb-tree size n-lookups)
(let ((test-rb-tree (make-test-rb-tree size)))
(show-time
(lambda ()
(do ((i 0 (fix:+ i 1))
(idx 0 (if (fix:> idx size)
0
(fix:+ idx 1)))
(answer '() (rb-tree/lookup test-rb-tree idx #f)))
((fix:>= i n-lookups) answer))))))
1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-rb-tree 10 100000000))
;process time: 3910 (3910 RUN + 0 GC); real time: 3908
;process time: 3810 (3810 RUN + 0 GC); real time: 3805
;process time: 4090 (4090 RUN + 0 GC); real time: 4090
;process time: 3970 (3970 RUN + 0 GC); real time: 3967
;process time: 4060 (4060 RUN + 0 GC); real time: 4051
;process time: 3980 (3980 RUN + 0 GC); real time: 3979
;process time: 4040 (4040 RUN + 0 GC); real time: 4040
;process time: 4090 (4090 RUN + 0 GC); real time: 4094
;process time: 3810 (3810 RUN + 0 GC); real time: 3810
;process time: 4090 (4090 RUN + 0 GC); real time: 4092
;Value: #t
1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-rb-tree 100 100000000))
;process time: 7700 (7700 RUN + 0 GC); real time: 7720
;process time: 7760 (7760 RUN + 0 GC); real time: 7767
;process time: 7700 (7700 RUN + 0 GC); real time: 7710
;process time: 7890 (7890 RUN + 0 GC); real time: 7893
;process time: 7920 (7920 RUN + 0 GC); real time: 7914
;process time: 7650 (7650 RUN + 0 GC); real time: 7646
;process time: 7740 (7740 RUN + 0 GC); real time: 7738
;process time: 7760 (7760 RUN + 0 GC); real time: 7761
;process time: 7670 (7670 RUN + 0 GC); real time: 7671
;process time: 8140 (8140 RUN + 0 GC); real time: 8136
;Value: #t
1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-rb-tree 1000 100000000))
;process time: 13130 (13130 RUN + 0 GC); real time: 13124
;process time: 13160 (13160 RUN + 0 GC); real time: 13153
;process time: 13150 (13150 RUN + 0 GC); real time: 13149
;process time: 13140 (13140 RUN + 0 GC); real time: 13140
;process time: 13310 (13310 RUN + 0 GC); real time: 13304
;process time: 13170 (13170 RUN + 0 GC); real time: 13172
;process time: 13140 (13140 RUN + 0 GC); real time: 13167
;process time: 13250 (13250 RUN + 0 GC); real time: 13238
;process time: 13300 (13300 RUN + 0 GC); real time: 13318
;process time: 13420 (13420 RUN + 0 GC); real time: 13416
;Value: #t
</pre>And wt-trees while we're at it:<br />
<pre>(define (make-test-wt-tree n-elements)
(alist->wt-tree number-wt-type (make-test-alist n-elements)))
(define (time-wt-tree size n-lookups)
(let ((test-wt-tree (make-test-wt-tree size)))
(show-time
(lambda ()
(do ((i 0 (fix:+ i 1))
(idx 0 (if (fix:> idx size)
0
(fix:+ idx 1)))
(answer '() (wt-tree/lookup test-wt-tree idx #f)))
((fix:>= i n-lookups) answer))))))</pre><pre>1 ]=> (do ((i 0 (+ i 1))) ((not (< i 10))) (time-wt-tree 100 100000000))
;process time: 6400 (6400 RUN + 0 GC); real time: 6397
;process time: 6740 (6740 RUN + 0 GC); real time: 6736
;process time: 6760 (6760 RUN + 0 GC); real time: 6763
;process time: 6070 (6070 RUN + 0 GC); real time: 6068
;process time: 6450 (6450 RUN + 0 GC); real time: 6461
;process time: 6800 (6800 RUN + 0 GC); real time: 6812
;process time: 6330 (6330 RUN + 0 GC); real time: 6346
;process time: 6060 (6060 RUN + 0 GC); real time: 6066
;process time: 6050 (6050 RUN + 0 GC); real time: 6039
;process time: 6300 (6300 RUN + 0 GC); real time: 6303
;Value: #t</pre><br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-37457451980992853132016-01-29T21:08:00.001-08:002016-01-29T21:08:28.224-08:00Alist vs. hash-tableAn <code>alist</code> is a simple data structure that holds key-value pairs in a linked list. When a key is looked up, the list is searched to find it. The time it takes is proportional to the length of the list, or the number of entries.<br />
<br />
A <code>hash-table</code> is a more complex data structure that holds key-value pairs in a set of "hash buckets". When a key is looked up, it is first "hashed" to find the correct bucket, then that bucket is searched for the entry. The time it takes depends on a number of things, the hash algorithm, the number of buckets, the number of entries in the bucket, etc. A hash-table can be faster than an alist because the hashing step is quick and the subsequent search step will have very few entries to search.<br />
<br />
In theory, an alist takes time proportional to the number of entries, but a hash-table takes constant time independent of the number of entries. Let's find out if this is true for MIT/GNU Scheme.<br />
<br />
I wrote a little program that measures how long it takes to look things up in an alist vs. a hash table. Here's what I measured:<div class="separator" style="clear: both; text-align: center;"><a href="http://3.bp.blogspot.com/-MdgIeqBU4X8/VqxAEB0ZAjI/AAAAAAAAM9Y/XJaFB5OSTKY/s1600/alist%2Bvs%2Bhash.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://3.bp.blogspot.com/-MdgIeqBU4X8/VqxAEB0ZAjI/AAAAAAAAM9Y/XJaFB5OSTKY/s1600/alist%2Bvs%2Bhash.png" /></a></div>It does indeed seem that alists are linear and hash tables are constant in lookup time. But the hashing step of a hash table does take time, so short alists end up being faster that hash tables. The breakeven point looks like a tad over 25 elements. So if you expect 25 or fewer entries, an alist will perform better than a hash table. (Of course different implementations will have different break even points.)<br />
<br />
A tree data structure is slightly more complex than an alist, but simpler than a hash table. Looking up an entry in a tree takes time proportional to the logarithm of the number of entries. The logarithm function grows quite slowly, so a tree performs pretty well over a very large range of entries. A tree is slower than an alist until you have about 15 entries. At this point, the linear search of an alist cannot compete with the logarithmic search of a tree. The time it takes to search a tree grows, but quite slowly. It takes more than 100 entries before a tree becomes as slow as a hash table.<br />
<div class="separator" style="clear: both; text-align: center;"><a href="http://4.bp.blogspot.com/-aCa3oU9gWgI/VqxD4gA7Z2I/AAAAAAAAM9k/S3rKUC5QAS4/s1600/tree%2Btoo.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://4.bp.blogspot.com/-aCa3oU9gWgI/VqxD4gA7Z2I/AAAAAAAAM9k/S3rKUC5QAS4/s1600/tree%2Btoo.png" /></a></div>With a big enough tree, the growth is so slow that you can pretend it is constant.<br />
<br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-68184348149364863552016-01-27T21:29:00.001-08:002016-01-27T21:55:42.063-08:00Latest amusementHere's a procedure that CDRs down a list until it hits the end:<br />
<pre>(define (last-cdr list)
(let loop ((tail list))
(if (pair? tail)
(loop (cdr tail))
tail)))
</pre>The inner loop of the procedure compiles to this:<br />
<pre>loop-3:
(cmp q (r 7) (@r 6)) ;; Interrupt check
(jge (@pcr interrupt-12))
(mov q (r 0) (@r 4)) ;; Fetch 'tail'
(mov q (r 1) (r 0)) ;; Extract the tag
(shr q (r 1) (&u #x3a))
(cmp b (r 1) (&u 1)) ;; Check for pair?, jump if not
(jne (@pcr label-14))
(and q (r 0) (r 5)) ;; Mask the tag
(mov q (r 1) (@ro 0 8)) ;; Fetch the CDR
(mov q (@r 4) (r 1)) ;; Assign 'tail'
(jmp (@pcr loop-3)) ;; Do it again.
</pre>On my laptop, each iteration of this loop takes a few nanoseconds.<br />
<p>I noticed that there seems to be a lot more going on than CDRing down a list. The interrupt check is responsible for a lot of the overhead. MIT/GNU Scheme polls for interrupts. The compiler inserts an interrupt check at every procedure entry and backwards branch. This ensures that only a small, bounded number of instructions can run between interrupt polls. The interrupt poll and the heap check are simultaneous because of a hack. To interrupt Scheme, you save the "Top of Heap" pointer and set it to zero. This causes the heap check to fail as if there were an out of memory condition. The out of memory handler first checks to see if this was actually an interrupt masquerading as an out of memory, and restores the heap pointer if so.<p>The two instructions,<br />
<pre>(cmp q (r 7) (@r 6)) ;; Interrupt check
(jge (@pcr interrupt-12))</pre>perform the check. The first compares register 7 with the contents of memory that register 6 points at. The convention for the compiler is that register 7 contains the free pointer and register 6 holds the address of MEMTOP. The interrupt check does a memory cycle.<br />
<p>The reason you poll for interrupts is that you need the virtual machine to be in a coherent state because the interrupt could attempt to run arbitrary code. The garbage collector in particular has to be able to parse the machine state<br />
at an interrupt. Interrupts are polled at apply time. Before application, the interrupts are checked. If an interrupt is to be processed, a continuation is pushed that will do the original application, and an interrupt handler is applied instead.<p>In MIT-Scheme, the virtual machine is a stack machine, and at apply time the entire state of the virtual machine is pointed to by the stack pointer. This is a good state to be in when you handle interrupts or garbage collect. But this means that arguments are passed on the stack. This instruction:<br />
<pre>(mov q (r 0) (@r 4))</pre>loads register 0 with the contents of memory at register 4. (The compiler convention is that register 4 is the stack pointer.) In other words, it is fetching the value of the argument <code>tail</code> from the stack. This is the second memory cycle.<br />
<p>Between interrupt polls, the compiled code can freely manipulate Scheme objects without worrying about being embarrassed by the garbage collector. But at apply time, when a possible interrupt poll could happen, the compiled code must put the virtual machine back into a coherent state. In particular, modified values are stored back on the stack.I This instruction just before the jump puts the value of <code>tail</code> back on the stack before jumping to the top of the loop.<br />
<pre>(mov q (@r 4) (r 1)) </pre>That's three memory cycles in addition to the actual fetching of the CDR in this instruction:<br />
<pre>(mov q (r 1) (@ro 0 8))</pre>Of course these are quite <em>inexpensive</em> memory cycles because the top of stack is cached, but there is at least the time time it takes to validate the cache entry.<p>The interrupt poll occurs every time around the loop, so we copy the arguments back and forth between the stack and registers on each iteration. If we unroll the loop we can avoid some of the copying:<br />
<pre>(define (last-cdr list)
(let loop ((tail list))
(if (pair? tail)
(loop (cdr tail))
tail)))
(define (last-cdr2 list)
(let loop ((tail list))
(if (not (pair? tail))
tail
(let ((tail (cdr tail)))
(if (not (pair? tail))
tail
(loop (cdr tail)))))))</pre>The loop in <code>last-cdr2</code> compiles to this:<br />
<pre>loop-6:
(cmp q (r 7) (@r 6)) ;; Interrupt check
(jge (@pcr interrupt-15))
(mov q (r 0) (@r 4)) ;; Fetch 'tail'
(mov q (r 1) (r 0)) ;; Extract the tag
(shr q (r 1) (&u #x3a))
(cmp b (r 1) (&u 1)) ;; Check for pair?
(jne (@pcr label-17))
(and q (r 0) (r 5)) ;; Mask the tag
(mov q (r 1) (@ro 0 8)) ;; Fetch the CDR
(mov q (@r 4) (r 1)) ;; Assign 'tail'
(mov q (r 0) (r 1))
(shr q (r 0) (&u #x3a)) ;; Extract the tag
(cmp b (r 0) (&u 1)) ;; Check for pair?
(jne (@pcr label-19))
(and q (r 1) (r 5)) ;; Mask the tag
(mov q (r 0) (@ro 1 8)) ;; Fetch the CDR
(mov q (@r 4) (r 0)) ;; Assign 'tail'
(jmp (@pcr loop-6)) ;; Do it again
</pre>If I count correctly, there are six memory cycles per iteration, two of which are CDRs. We also avoid a single <code>jmp</code> instruction per iteration.<p>Here's the timing on my machine:<br />
<pre>(test-last-cdr)
3.643 nanoseconds per cdr
3.643 nanoseconds per cdr
3.711 nanoseconds per cdr
3.643 nanoseconds per cdr
3.576 nanoseconds per cdr
(test-last-cdr2)
2.766 nanoseconds per cdr
2.699 nanoseconds per cdr
2.834 nanoseconds per cdr
2.699 nanoseconds per cdr
</pre><br />
<br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-84046275059068909122016-01-24T17:17:00.000-08:002016-01-24T17:17:56.203-08:00Locality and GC<p>I was curious about how long it took to CDR down a list. I wrote a little program that adds up the elements in a list<br />
and tried it out.<br />
<pre>(define test-list (iota (expt 10 6)))
(define (sum-list list)
(let loop ((total 0)
(tail list))
(if (pair? tail)
(loop (+ total (car tail)) (cdr tail))
(begin (if (not (null? tail))
(error:not-list list 'sum-list))
total))))
(define (test-sum-list n)
(do ((i 0 (+ i 1))
(answer '() (sum-list test-list)))
((not (< i n)) answer)))
1 ]=> (show-time (lambda () (test-sum-list 1000)))
;process time: 4280 (4280 RUN + 0 GC); real time: 4281
;Value: 499999500000
</pre>But after garbage collection, the performance dropped a bit.<br />
<pre>1 ]=> (gc-flip)
;GC #18 15:18:59: took: 0.13 (0%) CPU, 0.13 (0%) real; free: 246114893
;Value: 246114893
1 ]=> (show-time (lambda () (test-sum-list 1000)))
;process time: 4490 (4490 RUN + 0 GC); real time: 4483
;Value: 499999500000
</pre>Now it's taking 4.49 ms.<br />
<br />
The garbage collector in MIT Scheme is a very simple, stop the world, copying collector. The GC algorithm traverses the heap in breadth-first order. An undesired effect of this is data structures being spread about the heap. When I first built the test-list, the cons cells were close together. Here are the first few addresses:<br />
<pre>1 ]=> (do ((tail test-list (cdr tail))
(i 0 (+ i 1)))
((not (< i 10)) #f)
(display (object-datum tail))
(newline))
253936080
253936064
253936048
253936032
253936016
253936000
253935984
253935968
253935952
253935936
;Value: #f</pre>
But after garbage collection...
<pre>1 ]=> (gc-flip)
;GC #19 15:33:28: took: 0.15 (1%) CPU, 0.16 (0%) real; free: 246114593
;Value: 246114593
1 ]=> (do ((tail test-list (cdr tail))
(i 0 (+ i 1)))
((not (< i 10)) #f)
(display (object-datum tail))
(newline))
194190168
194326376
194416512
194499936
194555336
194584992
194609544
194631760
194652360
194669208
;Value: #f</pre>
All the cons cells are on different pages.
<p>This is annoying, so I hacked the GC so that it transports chains of cons-cells eagerly. If we do the same experiment,
before the flip,
<pre>1 ]=> (show-time (lambda () (test-sum-list 1000)))
;process time: 4280 (4280 RUN + 0 GC); real time: 4280
;Value: 499999500000
</pre>And after.
<pre>1 ]=> (gc-flip)
;GC #5 15:38:53: took: 0.23 (2%) CPU, 0.24 (0%) real; free: 249429521
;Value: 249429521
1 ]=> (show-time (lambda () (test-sum-list 1000)))
;process time: 4100 (4100 RUN + 0 GC); real time: 4100
;Value: 499999500000
</pre>
Now we see a performance increase. If we look at the test list,
<pre>1 ]=> (do ((tail test-list (cdr tail))
(i 0 (+ i 1)))
((not (< i 10)) #f)
(display (object-datum tail))
(newline))
193516792
193516808
193516824
193516840
193516856
193516872
193516888
193516904
193516920
193516936
;Value: #f</pre><br />
You can see that the cons-cells addresses are next to each other.<br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-11143022737350839112015-09-15T10:19:00.000-07:002015-09-15T10:19:23.093-07:00Integers and rationalsIn an earlier post, I asked readers to implement the bijection <code>rational->integer</code> and <code>integer->rational</code>. <a href="http://home.ccil.org/~cowan/">John Cowan</a> suggested the <a href="https://www.math.upenn.edu/~wilf/website/recounting.pdf">Calkin-Wilf tree</a> as a starting point. The Calkin-Wilf tree is a rooted binary tree where the nodes (or vertices, if you like) are labeled with positive rational numbers. It is <em>infinite</em> and <em>complete</em>: every node has two children. The Calkin-Wilf tree is constructed so that every rational number is assigned a unique node. Every positive rational number appears once and exactly once in the tree. The path from the root node to any selected rational is unique and can be encoded (in binary) as an integer.<br />
<pre>1 ]=> (rational->integer 355/113)
;Value: 67107847
1 ]=> (integer->rational 67107847)
;Value: 355/113
1 ]=> (cwt/value *the-calkin-wilf-tree*)
;Value: 1
1 ]=> (cwt/value (cwt/left *the-calkin-wilf-tree*))
;Value: 1/2
1 ]=> (cwt/value (cwt/right *the-calkin-wilf-tree*))
;Value: 2
1 ]=> (cwt/value (cwt/left (cwt/right (cwt/left (cwt/left *the-calkin-wilf-tree*)))))
;Value: 4/7</pre>Ho hum. We've all seen this sort of thing before.<br />
<br />
Here's the unusual part:<br />
<pre>1 ]=> cwt/left
;Value 1236: #[linear-fractional-transform 1236 x/(x + 1)]
1 ]=> cwt/right
;Value 1237: #[linear-fractional-transform 1237 (x + 1)]</pre>So I can write <br />
<pre>1 ]=> (cwt/value ((compose cwt/left cwt/right cwt/left cwt/left) *the-calkin-wilf-tree*))
;Value: 4/7
1 ]=> (lft/compose cwt/left cwt/right cwt/left cwt/left)
;Value 1260: #[linear-fractional-transform 1260 (3x + 1)/(5x + 2)]</pre>(See "<a href="http://funcall.blogspot.com/2015/08/playing-with-linear-fractional.html">Playing with Linear Fractional Transforms</a>")<br />
<hr />The <em>dyadic fractions</em> are those rational numbers whose denominator is a power of 2. Numbers like 1/4, 3/8, or 11/32. These are the divisions you'd find on a ruler (in the US). Floating point numbers are usually implemented as dyadic fractions.<br />
You can put the dyadic fractions into a binary tree as follows:<br />
<br />
<pre>(define *the-dyadic-fraction-tree* 1)
(define (dft/left node)
(/ (- (* (numerator node) 2) 1)
(* (denominator node) 2)))
(define (dft/right node)
(/ (+ (* (numerator node) 2) 1)
(* (denominator node) 2)))
1 ]=> *the-dyadic-fraction-tree*
;Value: 1
1 ]=> (dft/left *the-dyadic-fraction-tree*)
;Value: 1/2
1 ]=> (dft/right *the-dyadic-fraction-tree*)
;Value: 3/2
1 ]=> (dft/left (dft/left (dft/right (dft/left *the-dyadic-fraction-tree*))))
;Value: 9/16</pre>The next question is, what happens if I use a path derived from the Calkin-Wilf tree and use it on the dyadic fraction tree? Yes, this is a fairly random thing to try, but the trees are the same (that is, have the same structure) even if the values at the nodes are not. Either set of fractions is in a one-to-one mapping with the tree, so there is a one-to-one mapping between rational numbers and dyadic fractions. <br />
<div class="separator" style="clear: both; text-align: center;"><a href="http://4.bp.blogspot.com/-QcH_XudnNdA/VfhOYQ2yutI/AAAAAAAAKFk/hGyQn2GjHYg/s1600/Slippery.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://4.bp.blogspot.com/-QcH_XudnNdA/VfhOYQ2yutI/AAAAAAAAKFk/hGyQn2GjHYg/s320/Slippery.png" /></a></div>This is <a href="https://en.wikipedia.org/wiki/Minkowski%27s_question_mark_function">Minkowski's <code><b>?</b></code> (question mark) function</a>. It maps the rational numbers on the X axis to the dyadic fraction on the Y axis. It has a number of weird properties. For example, it is strictly increasing and continuous, but it is not <em>absolutely continuous</em>. The function does <em>not</em> have a derivative in the usual sense.Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-78790778128211445892015-09-13T14:44:00.000-07:002015-09-13T14:44:29.952-07:00A textbook caseThis is priceless. The url is <a href="http://imgur.com/tDSX24E">http://imgur.com/tDSX24E</a>. It says<br />
<blockquote><span style="font-family: Arial, Helvetica, sans-serif;">This is in a high school math textbook in Texas. </span><br />
<table border="1"><tbody>
<tr><td><b><span style="background-color: #3d85c6; color: #f3f3f3;"> Example 2 </span></b>: <b>Is there a one-to-one and onto correspondence between integers and rational numbers? </b><br />
<br />
<span style="font-family: Courier New, Courier, monospace; font-size: x-small;">... -4 -3 -2 -1 0 1 2 3 4 ...</span><br />
<span style="font-family: Courier New, Courier, monospace; font-size: x-small;">... -1/4 -1/3 -1/2 -1/1 -2/4 -2/3 -2/2 -2/1 -3/4 -3/3 -3/2 -3/1</span><br />
<br />
No matter how you arrange the sets, there is never one unique integer for each rational number. There is not a one-to-one and onto correspondence.</td></tr>
</tbody></table></blockquote><hr />The challenge: implement <code>rational->integer</code> that returns "one unique integer for each rational number", and its inverse, <code>integer->rational</code>.Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-91488373647444798172015-09-11T13:54:00.002-07:002015-09-11T13:54:33.331-07:00Currying and confusionA friend of mine recently said to me "Don't know anything about currying except for food". I'm sure that nearly everyone who reads this blog is familiar with currying functions (and has probably curried a function within the last few hours), but it makes a good blog topic anyway.<br />
<br />
"Currying" a function (as opposed to an entrÃ©e) is named after <a href="https://en.wikipedia.org/wiki/Haskell_Curry">Haskell Curry</a>, but he was inspired by a paper by <a href="https://en.wikipedia.org/wiki/Moses_Sch%C3%B6nfinkel">Moses SchÃ¶nfinkel</a>, and it appears that <a href="https://en.wikipedia.org/wiki/Gottlob_Frege">Gottlob Frege</a> came up with idea. So much for the name.<br />
<br />
Pick your favorite binary function. I like "multiply", but any binary function will do. It need not be associative or commutative. As an example, imagine a <code>print-to</code> function that takes a document and a device.<br />
<br />
Now consider these unary functions:<br />
<pre>(define (multiply-by-five n) (* 5 n))
(define (multiply-by-negative-one n) (* -1 n))
(define (multiply-by-thirty-seven n) (* 37 n))
<i>etc.</i></pre>There is an obvious pattern here that we can abstract out:<br />
<pre>(define (make-multiply-by x) (lambda (n) (* x n))
(define multiply-by-five (make-multiply-by 5))
(define multiply-by-negative-one (make-multiply-by -1))
(define multiply-by-thirty-seven (make-multiply-by 37))</pre>Or, if we use <code>print-to</code><br />
<pre>(define (make-print-to-device device) (lambda (doc) (print-to doc device)))
(define print-to-inkjet (make-print-to-device the-inkjet-printer))
(define print-to-daisywheel (make-print-to-device the-daisy-wheel-printer))</pre>Note the similarity between <code>make-multiply-by</code> and <code>make-print-to-device</code>.<br />
<pre>(define (make-multiply-by x) (lambda (n) (* x n))
(define (make-print-to-device device) (lambda (doc) (print-to doc device)))
(define (make-<<i>unary</i>> an-argument)
(lambda (another-argument) (<<i>binary></i> an-argument another-argument)))</pre>We can abstract this operation:<br />
<pre>(define (make-unary-maker binary-operation)
(define (make-unary-operation an-argument)
(lambda (other-argument)
(binary-operation an-argument other-argument)))
make-unary-operation)</pre>We have a pile of functions, all similar because they were created with the <code>make-</code> function. And the <code>make-</code> functions are all similar because they were created with <code>make-unary-maker</code>.<br />
<br />
This is the meta-operation we call "currying". We take a function of several arguments, decide on some fixed values for some subset of arguments, and return a new function of the remaining, unfixed arguments.<br />
<hr /><br />
Captain Obvious has a few things to say about functions.<br />
<br />
<span style="color: #6aa84f;">A function won't return a value unless you call it.</span><div><span style="color: #6aa84f;"><br />
</span> The <em>cardinality</em> of the set of return values cannot be larger than the cardinality of the set of valid arguments. Functions don't make up values. There can be <em>fewer</em> possible return values than possible valid arguments, but never more.<br />
<br />
<span style="color: #6aa84f;">If two sets are different sizes, then if you try to pair up elements from each set, you'll have some left over.</span><br />
<br />
If we compose two functions and the set of possible output from the first is different in size from the set of possible valid input to the second, then there will either be output from the first that the second cannot accept, or possible inputs to the second that the first cannot produce. The latter case isn't a problem, but in the former case, you'll get an error.<br />
<br />
<span style="color: #6aa84f;">If you "invert" a function, its output becomes input and <i>vice versa</i>.</span><br />
<br />
Since inverse functions (when they exist, that is) are functions, The same constraints on the cardinality of input and output apply, but in the other direction. If you invert a composition, then the valid arguments and results swap roles. If the cardinalities match, we're cool, but if there is a mismatch, we're in the opposite situation of the non-inverse, and what was not an error (<i>i.e.</i> accepting an input that can never be produced) becomes one (<i>i.e.</i> producing a value that cannot be accepted).<br />
<br />
If the appropriate cardinalities never increase, you can compose two functions. If the appropriate cardinalities match, you can invert the composition.<br />
<hr /><p>What does this have to do with currying?</p><p>I'm reading a bit about group theory and I chanced upon some exposition that was thick with comments and arguments surrounding the cardinality of various sets and subsets within the group. Once the exposition introduced a number of sets with equal cardinalities, the author pointed out that you can define an invertible function between any two sets with the same cardinality. Since the set of integers and the set of <code>multiply-by-</code> functions have the same cardinality, you could define a function that maps integers to <code>multiply-by-</code> functions. This isn't much of a revelation because that's what we did to get those functions in the first place. After slogging through this, I finally worked out what they were trying to say: "You can curry the binary operation." But they completely avoided the word "curry", and made arguments about set cardinality.</p><p>The next paragraph in the exposition was worse. You can curry the other argument to the binary operation. This leads to a completely different set of curried functions over a different set of arguments. Now it ultimately doesn't matter which argument you curry, when all is said and done, both arguments show up and are passed to the binary function. But all the intermediate values are drawn from different sets than if you curried the other way. It takes a very complicated argument about cardinalities to derive that either way of currying will work.</p></div>Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-64994689255702229002015-09-09T07:48:00.000-07:002015-09-09T07:48:47.304-07:00Something less abstract<html><br />
<style>
pre {
border:1px dashed #aaaaaa;
background:#eeeeee;
white-space:pre;
font-family:monospace;
font-size:9pt;
line-height: 10pt;
height:auto;
width:auto;
padding:5px;
margin-top: .75em;
margin-left:10px;
margin-bottom: .75em;
overflow:auto;
}</style><br />
<p>To recap, a linear fractional transform (<em>lft</em>) is a function of this form:<br />
<pre>(lambda (x)
(/ (+ (* A x) B)
(+ (* C x) D)))</pre><p>Using an object-oriented extension to Scheme, I've given these functions a special print method so they look pretty. (I'm using <a href="http://www.gnu.org/software/mit-scheme/">MIT/Gnu Scheme</a> with <a href="http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-sos.pdf">SOS</a>, a CLOS-like object system. I haven't included all the code in my posts, but it should be easy for an intermediate programmer to replicate this.)<br />
<pre>1 ]=> (make-linear-fractional-transform 1 2 3 4)
;Value 13: #[linear-fractional-transform 13 (x + 2)/(3x + 4)]</pre>But otherwise they are normal one argument functions. Since they take and return objects of the same type, you can chain them together with function composition.<br />
<pre>(define foo (make-linear-fractional-transform 1 2 3 4))
(define bar (make-linear-fractional-transform 1 4 0 2))
1 ]=> (compose foo bar)
;Value 14: #[compiled-closure 14 (lambda "global" #x35) #x84 #x25de16c #x3a5ea78]
1 ]=> ((compose foo bar) 1/10)
;Value: 81/203</pre><code>lft/compose</code> knows to explicitly construct an lft rather than a generic closure,<br />
<pre>1 ]=> (lft/compose foo bar)
;Value 15: #[linear-fractional-transform 15 (x + 8)/(3x + 20)]
1 ]=> ((lft/compose foo bar) 1/10)
;Value: 81/203
</pre>but there is no difference when you apply the composed function.</p><br />
<p>I've been distracted by group theory, so let's do something less abstract. Here is an infinite stream of linear fractional transforms.<br />
<pre>(define lft-stream
(cons-stream
(make-linear-fractional-transform 0 4 1 0)
(stream-map
(lambda (n d)
(make-linear-fractional-transform n 1 d 0))
(odds)
(cons-stream 1 (stream-map square (naturals))))))
1 ]=> (pp (stream-head lft-stream 10))
(#[linear-fractional-transform 17 4/x]
#[linear-fractional-transform 26 (x + 1)/x]
#[linear-fractional-transform 25 (3x + 1)/x]
#[linear-fractional-transform 34 (5x + 1)/4x]
#[linear-fractional-transform 33 (7x + 1)/9x]
#[linear-fractional-transform 32 (9x + 1)/16x]
#[linear-fractional-transform 31 (11x + 1)/25x]
#[linear-fractional-transform 30 (13x + 1)/36x]
#[linear-fractional-transform 29 (15x + 1)/49x]
#[linear-fractional-transform 28 (17x + 1)/64x])</pre><p>This is a stream of functions, so let's compose them. Imagine our function stream is <code>(f g h ...)</code>. We want to generate the stream <code>(f (compose f g) (compose f g h) ...)</code><br />
<pre>1 ]=> (fold-stream lft/compose lft:identity lft-stream)
;Value 36: {#[linear-fractional-transform 37 x] ...}
1 ]=> (pp (stream-head (fold-stream lft/compose lft:identity lft-stream) 10))
(#[linear-fractional-transform 37 x]
#[linear-fractional-transform 17 4/x]
#[linear-fractional-transform 45 4x/(x + 1)]
#[linear-fractional-transform 44 (12x + 4)/(4x + 1)]
#[linear-fractional-transform 43 (19x + 3)/(6x + 1)]
#[linear-fractional-transform 42 (160x + 19)/(51x + 6)]
#[linear-fractional-transform 41 (1744x + 160)/(555x + 51)]
#[linear-fractional-transform 40 (23184x + 1744)/(7380x + 555)]
#[linear-fractional-transform 39 (10116x + 644)/(3220x + 205)]
#[linear-fractional-transform 38 (183296x + 10116)/(58345x + 3220)])
</pre><p>Let's apply these transforms to a number. 42 is random enough.<br />
<pre>1 ]=> (pp (stream-head
(stream-map
(lambda (transform) (transform 42.0))
(fold-stream lft/compose lft:identity lft-stream))
10))
(42.
.09523809523809523
3.9069767441860463
3.0059171597633134
3.16600790513834
3.137337057728119
3.1423312358203845
3.141464985588458
3.1416146775443905
3.1415888593191537)</pre>That looks familiar. We'll pick a point further on in the stream.<br />
<pre>1 ]=> (stream-ref (fold-stream lft/compose lft:identity lft-stream) 20)
;Value 48: #[linear-fractional-transform 48 (2166457145737216x + 48501417558016)/(689604727481670x + 15438480702645)]
1 ]=> ((stream-ref (fold-stream lft/compose lft:identity lft-stream) 20) 1.0)
;Value: 3.1415926535898056</pre>This stream of functions are functions that approximate π. Each element in the stream is a function that is a better approximation of π than the last.<br />
<pre>1 ]=> (stream-ref (fold-stream lft/compose lft:identity lft-stream) 10)
;Value 51: #[linear-fractional-transform 51 (3763456x + 183296)/(1197945x + 58345)]
1 ]=> (define foo (stream-ref (fold-stream lft/compose lft:identity lft-stream) 10))
1 ]=> (foo 0.0)
;Value: 3.1415888250921244
1 ]=> (foo 1.0)
;Value: 3.141593103503172
1 ]=> (exact->inexact (foo 'infinity))
;Value: 3.1415933118799275
</pre>Ok, let's subtract off that three.<br />
<pre>(define (make-lft-subtract n)
(make-linear-fractional-transform 1 (- n) 0 1))
1 ]=> (lft/compose (make-lft-subtract 3) foo)
;Value 54: #[linear-fractional-transform 54 (169621x + 8261)/(1197945x + 58345)]
1 ]=> ((lft/compose (make-lft-subtract 3) foo) 42.)
;Value: .14159330668296408
</pre>And multiply by ten<br />
<pre>(define (make-lft-multiply n)
(make-linear-fractional-transform n 0 0 1))
1 ]=> (lft/compose (make-lft-multiply 10) (make-lft-subtract 3) foo)
;Value 55: #[linear-fractional-transform 55 (339242x + 16522)/(239589x + 11669)]
1 ]=> ((lft/compose (make-lft-multiply 10) (make-lft-subtract 3) foo) 42.)
;Value: 1.4159330668296406
</pre>and now the next decimal digit is in the ones place. If we repeat this process, we'll generate the decimal digits of our approximation to π one at a time.<br />
<pre>1 ]=> ((lft/compose (make-lft-multiply 10) (make-lft-subtract 3) foo) 42.)
;Value: 1.4159330668296406
1 ]=> ((lft/compose (make-lft-multiply 10)
(make-lft-subtract 1)
(make-lft-multiply 10)
(make-lft-subtract 3) foo) 42.)
;Value: 4.159330668296407
1 ]=> ((lft/compose (make-lft-multiply 10)
(make-lft-subtract 4)
(make-lft-multiply 10)
(make-lft-subtract 1)
(make-lft-multiply 10)
(make-lft-subtract 3) foo) 42.)
;Value: 1.5933066829640692
</pre>We'll define a <code>composition</code> as a data structure with an lft and a <code>promise</code> (delayed evaluation) to provide more lfts to compose. Operations on a <code>composition</code> will work on the lft and try to avoid forcing the promise if possible. If the lft isn't a good enough approximation, we force the promise, get a new lft, and create a new <code>composition</code>. <br />
<pre>(define-class (<lft-composition>
(constructor make-lft-composition
(linear-fractional-transform promise)))
()
(linear-fractional-transform define accessor accessor composition-transform)
(promise define accessor accessor composition-promise))
(define (composition/refine lft-composition)
(let ((lft (composition-transform lft-composition))
(lft-stream (force (composition-promise lft-composition))))
(make-lft-composition (lft/compose lft (head lft-stream)) (cdr lft-stream))))
</pre>Getting the integer part of a <code>composition</code> involves getting the integer part of the transform, if possible, and if not, refining the composition until it is possible. <code>composition/integer-and-fraction</code> returns two values: the integer extracted, and the final composition remaining after any refinement steps and after subtracting off the integer.</p><pre>(define (composition/%integer-part lft-composition)
(lft/integer-part (composition-transform lft-composition)))
(define (composition/integer-and-fraction lft-composition)
(let ((integer (composition/%integer-part lft-composition)))
(if (not integer)
(composition/integer-and-fraction (composition/refine lft-composition))
(values integer (make-lft-composition
(lft/compose
(make-linear-fractional-transform 1 (- integer) 0 1)
(composition-transform lft-composition))
(composition-promise lft-composition))))))
</pre>We'll create a stream of digits by peeling off the integer parts and multiplying the fraction by 10.<br />
<pre>(define (composition->digit-stream c radix)
(receive (ipart fpart) (composition/integer-and-fraction c)
(cons-stream
ipart
(composition->digit-stream
(make-lft-composition
(lft/compose (make-linear-fractional-transform radix 0 0 1)
(composition-transform (force fpart)))
(composition-promise (force fpart)))
radix))))
(define foocomp (make-lft-composition (head lft-stream) (cdr lft-stream)))
1 ]=> (stream-head (composition->digit-stream foocomp 10) 50)
;Value 204: (3 1 4 1 5 9 2 6 5 3 5 8 9 7 9 3 2 3 8 4 6 2 6 4 3 3 8 3 2 7 9 5 0 2 8 8 4 1 9 7 1 6 9 3 9 9 3 7 5 1)
</pre><br />
</html>Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-80141372478283885512015-09-06T16:15:00.000-07:002015-09-06T16:15:06.620-07:00Flipping the number line<p>Here is a number line. It looks funny because I did two things: first, I stretched and compressed different parts so I could fit <em>all</em> the numbers in. Second, I rolled it into a circle.<div class="separator" style="clear: both; text-align: center;"><a href="https://docs.google.com/drawings/d/1daNUd-S2EoNhOacXXq-5gwHKkFbLwQ7KFZzAgKjFKy8/pub?w=480&h=192" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="https://docs.google.com/drawings/d/1daNUd-S2EoNhOacXXq-5gwHKkFbLwQ7KFZzAgKjFKy8/pub?w=480&h=192" /></a></div><p>All the numbers are in there. Most of them are really crammed near the top.</p><p>What happens to the number line if you apply a linear fractional transform? Here I apply <code>1/x</code>:<br />
<div class="separator" style="clear: both; text-align: center;"><a href="https://docs.google.com/drawings/d/1UVWEYff15yCkUtwxi1GF6EDc5opRurkYrob3X3P-ew8/pub?w=483&h=371" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="https://docs.google.com/drawings/d/1UVWEYff15yCkUtwxi1GF6EDc5opRurkYrob3X3P-ew8/pub?w=483&h=371" /></a></div><p><code>1/x</code> flips the entire diagram vertically. (What happens if you apply <code>-x</code>?)</p><p>In this example, I apply <code>x + 1</code>:<div class="separator" style="clear: both; text-align: center;"><a href="https://docs.google.com/drawings/d/1viTU0kLoEydWCCo13fgaGIHQ-swWShRCtz97IsN7V2k/pub?w=480&h=195" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="https://docs.google.com/drawings/d/1viTU0kLoEydWCCo13fgaGIHQ-swWShRCtz97IsN7V2k/pub?w=480&h=195" /></a></div><p>The numbers in the circle rotate clockwise, but not exactly linearly. The negative numbers are compressed and the positive numbers expanded.</p><p>There are, of course, an unlimited number of linear fractional transformations I can apply to my number line, but they all act by flipping or rotating the number line in some manner. We can derive <em>every</em> transform by a sequence of flips and rotates. Can we find a basic set of operations from which we can construct all the rest?</p><p>We can enumerate all the linear fractional transforms the same way we enumerate all rational numbers. We conceptually make a table of all of them, but we walk the table diagonally. There are four integers per linear fractional transform, rather than the two in a rational number, but that makes only a minor difference. It seems likely that our basic set of operations will be found in the set of linear fractional transforms with small integers for coefficients. If we use the positive and negative integers with absolute value of four or less, we'll have a good sized set to start with. Just from the combinatorics, we'd expect <code>(expt 9 4)</code> possible ways to list them, but many of these are duplicates. Nonetheless, there are still 2736 unique linear fractional transforms with coefficients that have an absolute value of four or less.</p><p>(I'm tired of typing "linear fractional transform". I'm going to abbreviate it <em>lft</em>.)</p><p>What happens if you compose an lft with itself? Obviously constants and identity remain unchanged, but the other ones are more interesting. These lfts are self inverses. If you compose them with themselves, you get the identity:<br />
<pre>#[linear-fractional-transform 20 -x]
#[linear-fractional-transform 14 1/x]
#[linear-fractional-transform 13 -1/x]
#[linear-fractional-transform 227 x/(x - 1)]
#[linear-fractional-transform 226 -x/(x + 1)]
#[linear-fractional-transform 225 -(x + 1)]
#[linear-fractional-transform 224 (1 - x)]
#[linear-fractional-transform 223 (x + 1)/(x - 1)]
#[linear-fractional-transform 222 (1 - x)/(x + 1)]</pre>These ones are not identities when you compose them twice <code>(lft/compose x x)</code>, but they <em>are</em> identities if you compose them three times <code>(lft/compose x x x)</code><br />
<pre>#[linear-fractional-transform 522 1/(1 - x)]
#[linear-fractional-transform 521 -1/(x + 1)]
#[linear-fractional-transform 397 -(x + 1)/x]
#[linear-fractional-transform 396 (x - 1)/x]</pre><div class="separator" style="clear: both; text-align: center;"><a href="https://docs.google.com/drawings/d/1Vdvdg1A2pMhMa2VVXVKv8mRRxuDwGxH5aLbwF0i4-Po/pub?w=481&h=192" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="https://docs.google.com/drawings/d/1Vdvdg1A2pMhMa2VVXVKv8mRRxuDwGxH5aLbwF0i4-Po/pub?w=481&h=192" /></a></div>These two are examples that require four composes<br />
<pre>#[linear-fractional-transform 528 (x + 1)/(1 - x)]
#[linear-fractional-transform 527 (x - 1)/(x + 1)]</pre><p>And these examples require six:<pre>#[linear-fractional-transform 59 (x + 1)/(2 - x)]
#[linear-fractional-transform 58 (x - 1)/(x + 2)]
#[linear-fractional-transform 57 (2x + 1)/(1 - x)]
#[linear-fractional-transform 56 (2x - 1)/(x + 1)]
#[linear-fractional-transform 55 1/(3 - 3x)]
</pre><div class="separator" style="clear: both; text-align: center;"><a href="https://docs.google.com/drawings/d/1-dM6reN3HLG2UMqkx6y60V6bdxG4kYPMow3u-W5w54A/pub?w=461&h=567" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="https://docs.google.com/drawings/d/1-dM6reN3HLG2UMqkx6y60V6bdxG4kYPMow3u-W5w54A/pub?w=461&h=567" /></a></div><p>I have not seen an lft that gives the identity when composed with itself five times, nor seven, or eight.</p><p>Some lfts never self compose to identities. Obviously repeated self composition of <code>x+1</code> will never equal the identity.</p><br />
<br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-7377244689653485032015-09-01T20:20:00.001-07:002015-09-01T20:20:53.119-07:00Linear fractional transforms and permutations<html><br />
<p>So what does group theory have to do with linear fractional transforms? I'm glad you asked. The answer is pretty complicated, though.</p><p>There's no good place to start here, so let's just dive in. This function computes the <code>cross-ratio</code> of four numbers:<br />
<pre>(define (cross-ratio A B C D)
(/ (* (- a b) (- c d))
(* (- a d) (- c b))))
1 ]=> (cross-ratio 1 9 5 13)
;Value: 4/3
</pre><p>There's a geometric interpretation of the cross ratio, but for the moment, just think of it as a function that takes any four numbers and produces a value.<br />
<pre>1 ]=> (cross-ratio 3 2 1 9)
;Value: -4/3
1 ]=> (cross-ratio 5 1 8 4)
;Value: 16/7
</pre><p>The cross ratio is preserved under linear fractional transforms:<br />
<pre>1 ]=> (define lft2 (make-linear-fractional-transform 3 -1 2 7))
;Value: lft2
1 ]=> (cross-ratio (lft2 3) (lft2 2) (lft2 1) (lft2 9))
;Value: -4/3
1 ]=> (cross-ratio (lft 3) (lft 2) (lft 1) (lft 9))
;Value: -4/3
1 ]=> (cross-ratio 3 2 1 9)
;Value: -4/3
</pre><p>The cross ratio is also preserved under <em>some</em> permutations of its arguments.<br />
<pre>1 ]=> (cross-ratio 3 2 1 9)
;Value: -4/3
1 ]=> (cross-ratio 1 9 3 2)
;Value: -4/3
1 ]=> (cross-ratio 2 3 9 1)
;Value: -4/3
</pre>but not all<br />
<pre>1 ]=> (cross-ratio 3 2 9 1)
;Value: 4/7
1 ]=> (cross-ratio 2 9 3 1)
;Value: 7/3
</pre><p>Now here's the interesting part. There's a linear fractional transform that will "undo" the permutation of the arguments to cross-ration.<br />
<pre>1 ]=> ((make-linear-fractional-transform -1 1 0 1) 7/3)
;Value: -4/3
1 ]=> ((make-linear-fractional-transform 1 0 1 -1) 4/7)
;Value: -4/3
</pre>There are 24 permutations of the argument list to <code>cross-ratio</code>, and here are the equivalence classes:<br />
<pre>((-4/3 (1 9 3 2) (2 3 9 1) (3 2 1 9) (9 1 2 3))
(-3/4 (1 2 3 9) (2 1 9 3) (3 9 1 2) (9 3 2 1))
(3/7 (1 2 9 3) (2 1 3 9) (3 9 2 1) (9 3 1 2))
(4/7 (1 9 2 3) (2 3 1 9) (3 2 9 1) (9 1 3 2))
(7/4 (1 3 2 9) (2 9 1 3) (3 1 9 2) (9 2 3 1))
(7/3 (1 3 9 2) (2 9 3 1) (3 1 2 9) (9 2 1 3)))</pre>And these are the linear fractional transforms that permute among these:<br />
<pre>(#[linear-fractional-transform 89333 x]
#[linear-fractional-transform 89334 1/x]
#[linear-fractional-transform 89335 (1 - x)]
#[linear-fractional-transform 89403 1/(1 - x)]
#[linear-fractional-transform 89370 x/(x - 1)]
#[linear-fractional-transform 89393 (x - 1)/x])</pre><p>This is cool. Instead of thinking of a linear fractional transform as a continuous function that traces out a hyperbola, or as an interval on the real number line, we can think of a linear fractional transform as a function that computes a permutation.</p><hr /><p>Here is a function called <code>d3</code> that is defined on the symbols <code>a</code>, <code>b</code>, <code>c</code>, <code>d</code>, <code>e</code>, and <code>f</code>.<br />
<pre>1 ]=> (d3 'a 'b)
;Value: d
</pre>With six symbols, there's only 36 possible outcomes, so we can enumerate them:<pre> a b c d e f
a ((e d f b a c)
b (f e d c b a)
c (d f e a c b)
d (c a b f d e)
e (a b c d e f)
f (b c a e f d))</pre><p>Here's a hack. The identity element can be seen to be <code>'e</code>, so list that row and column first:<br />
<pre> e a b c d f
e ((e a b c d f)
a (a e d f b c)
b (b f e d c a)
c (c d f e a b)
d (d c a b f e)
f (f b c a e d))</pre><p>Now the table headers are exactly the same as the first entries in the respective rows or columns, so you can do without them.<br />
<pre>((e a b c d f)
(a e d f b c)
(b f e d c a)
(c d f e a b)
(d c a b f e)
(f b c a e d))</pre><p>Another weird thing is that you can permute any rows but the first, or permute any columns but the first, and still have an equivalent table.</p><p>Anyway, d3 is the "symmetry group" of a triangle. Here the operations are<br />
<pre>e = leave it alone
f = rotate clockwise 120 degrees
d = rotate counter-clockwise 120 degrees
a = hold vertex A in place, and flip the triangle over swapping vertex B and C
b = hold vertex B in place, and flip the triangle over swapping vertex A and C
c = hold vertex C in place, and flip the triangle over swapping vertex A and B
</pre>Now consider this,<br />
<pre>e = #[linear-fractional-transform 89333 x]
f = #[linear-fractional-transform 89393 (x - 1)/x]
d = #[linear-fractional-transform 89403 1/(1 - x)]
a = #[linear-fractional-transform 89370 x/(x - 1)]
b = #[linear-fractional-transform 89335 (1 - x)]
c = #[linear-fractional-transform 89334 1/x]
</pre><p>Just as d3 permutes a triangle, these linear fractional transforms permute among the equivalence classes of cross ratios.</p><br />
</html><br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-7986688850081873722015-08-27T11:18:00.000-07:002015-08-27T11:18:27.089-07:00n-ary functions and argument listsSuppose we have a binary operation <code>Op2 = (lambda (left right) ...)</code>. If it is closed over some type, you can make expression trees.<br />
<pre>(Op2 (Op2 <i><arg1></i> <i><arg2></i>)
(Op2
(Op2 <i><arg3></i> <i><arg4></i>)
<i><arg5></i>))</pre>If <code>Op2</code> is associative as well, these are equal:<br />
<pre>(Op2 (Op2 <i><arg1></i> <i><arg2></i>)
(Op2 <i><arg3></i>
(Op2 <i><arg4></i> <i><arg5></i>)))
(Op2 <i><arg1></i>
(Op2 (Op2 <i><arg2></i> <i><arg3></i>)
(Op2 <i><arg4></i> <i><arg5></i>)))</pre><br />
This makes the tree structure irrelevant so long as the fringe of the tree stays in order, so we can flatten the tree by making an N-ary version of the binary operation:<br />
<pre>(define (binary->nary Op2)
(lambda (a1 a2 . an)
(fold-left Op2 (Op2 a1 a2) an)))
((binary->n-ary Op2) <i><arg1></i> <i><arg2></i> <i><arg3></i> <i><arg4></i> <i><arg5></i> <i><arg6></i> <i>etc.</i>)</pre>The value of this expression naturally depends upon the values of the arguments. Changing the argument list is highly likely to change the value of the entire expression. However, we can make certain changes to the argument list without changing the value of the entire expression. If we know what those changes are, we can manipulate the argument list before invoking the operator, and still get the same answer. Naturally, most of the changes we can make to the argument list depend on the specifics of <code>Op2</code>, but it turns out that some interesting changes are possible without knowing any specifics, only knowing a few high-level properties of <code>Op2</code>.<br />
<br />
Obviously, the first thing we can do is reduce the argument list through evaluation. Simply replace the first two arguments with the value of <code>(Op2 <i><arg1></i> <i><arg2></i>)</code><br />
<pre>((binary->n-ary Op2) <i><arg1></i> <i><arg2></i> <i><arg3></i> <i><arg4></i> <i><arg5></i> <i><arg6></i> <i>etc.</i>) =
((binary->n-ary Op2) (Op2 <i><arg1></i> <i><arg2></i>) <i><arg3></i> <i><arg4></i> <i><arg5></i> <i><arg6></i> <i>etc.</i>) =
((binary->n-ary Op2) <i><result></i> <i><arg3></i> <i><arg4></i> <i><arg5></i> <i><arg6></i> <i>etc.</i>)</pre>Since <code>Op2</code> is associative, we can replace any 2 adjacent arguments with their combination.<br />
<br />
Now suppose there is an identity element among the arguments we can give to Op2.<br />
<pre>(Op2 <i><arg></i> id) = <i><arg></i> <i>and</i>
(Op2 id <i><arg></i>) = <i><arg></i></pre>We can do this:<br />
<pre>(define (binary->nary Op2)
(lambda an
(fold-left Op2 id an)))
(define Op (binary->nary Op2))</pre>Which is cleaner than the original. We also get a new way to manipulate the argument list to <code>Op</code>. We can add the identity element anywhere we wish, or we can delete the identity element wherever we find one.</code><br />
<pre>(Op <i><arg1></i> <i><arg2></i> <i><arg3></i> Id <i><arg4></i> <i><arg5></i> <i><arg6></i> <i>etc.</i>) =
(Op <i><arg1></i> <i><arg2></i> <i><arg3></i> <i><arg4></i> <i><arg5></i> <i><arg6></i> <i>etc.</i>) =
(Op <i><arg1></i> Id <i><arg2></i> <i><arg3></i> <i><arg4></i> <i><arg5></i> Id <i><arg6></i> <i>etc.</i>)</pre><br />
One more restriction. We want <code>Op2</code> to be invertible. Suppose <code>(Op2 <i><arg1></i> <i><arg2></i>) = <i><result></i></code>. <code>Op2</code> is invertible if, given any two of <i><arg1></i>, <i><arg2></i>, and <i><result></i>, the third can be uniquely determined. If you have one <i><arg></i> and a <i><result></i>, you can run things backwards and get the other <i><arg></i>.<br />
<br />
Requiring <code>Op2</code> to be invertible has many consequences, some of them quite non-obvious. An obvious consequence, though, is that we can define inverse elements. If <code>(Op2 <i><argA></i> <i><argB></i>) = Id</code>, then we say that <i><argB></i> is the inverse of <i><argA></i> (and vice versa). We find the inverse of an argument by fixing the output as the identity element and running <code>Op2</code> backwards to find the other argument.<br />
<br />
This gives us the final way to manipulate the argument list. If an element appears next to its inverse, both can be removed:<br />
<pre>(Op <i><arg1></i> <i><arg2></i> <i><arg3></i> (inverse <i><arg3></i>) <i><arg5></i> <i><arg6></i> <i>etc.</i>) =
(Op <i><arg1></i> <i><arg2></i> (Op2 <i><arg3></i> (inverse <i><arg3></i>)) <i><arg5></i> <i><arg6></i> <i>etc.</i>) =
(Op <i><arg1></i> <i><arg2></i> Id <i><arg5></i> <i><arg6></i> <i>etc.</i>) =
(Op <i><arg1></i> <i><arg2></i> <i><arg5></i> <i><arg6></i> <i>etc.</i>)</pre><br />
So here are all the restrictions on Op2:<br />
<ul><li>Closed over an set of arguments</li>
<li>Associative</li>
<li>Has an identity argument</li>
<li>Invertible</li></ul>If <code>Op2</code> has these properties (and a lot of binary operations do), then we can define an n-ary <code>Op</code> and play with its argument list. If you do this, you might notice that it looks kind of familiar:<br />
<pre>(op f g (inverse g) j id h) = (op f j id h) = (op f j h)</pre><br />
The argument list sort of looks like a function pipeline. The allowed manipulations of the argument list are compatible with a function pipeline, too. In fact, it could <i>be</i> a function pipeline if <code>Op</code> is the <code>compose</code> operator, and <code>f</code>, <code>g</code>, and <code>h</code> are appropriate invertible unary functions. But whatever it is, the point is that it looks enough like a function pipeline that we can pretend that it is. <br />
<br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-69833393680112717122015-08-23T12:23:00.000-07:002015-08-23T12:23:43.686-07:00Playing with linear fractional transformsI wanted to play with continued fractions and linear fractional transforms, so I wrote some code to make it easier. A linear fractional transform (also called a homographic function or Mobius transform) is a function like this:<br />
<div class="separator" style="clear: both; text-align: center;"><a href="http://1.bp.blogspot.com/-Rcot2E2rBz4/VAYCfooXuNI/AAAAAAAAIV8/yHOz_V6D6mU/s1600/homographic.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://1.bp.blogspot.com/-Rcot2E2rBz4/VAYCfooXuNI/AAAAAAAAIV8/yHOz_V6D6mU/s1600/homographic.png" /></a></div>In MIT/GNU Scheme:<br />
<pre>;; x => (3x + 1)/(x + 4)
1 ]=> (define foo (make-linear-fractional-transform 3 1 1 4))
;Value: foo
1 ]=> (foo 2)
;Value: 7/6
</pre>I used an <i>entity</i> object so, in addition to invoking it on a number, there are two more ways to manipulate a linear fractional transform:<br />
<pre>;; A predicate
1 ]=> (linear-fractional-transform? foo)
;Value: #t
;; And a CPS accessor
1 ]=> (lft/spread-coefficients foo (lambda (A B C D) (list A B C D)))
;Value 307: (3 1 1 4)
</pre>I also added a print method:<br />
<pre>1 ]=> foo
;Value 308: #[linear-fractional-transform 308 (3x + 1)/(x + 4)]
</pre><br />
As I mentioned in a prior post, you can partly apply a linear fractional transform:<br />
<pre>1 ]=> foo
;Value 308: #[linear-fractional-transform 308 (3x + 1)/(x + 4)]
1 ]=> (lft/partly-apply foo 2)
;Value 315: #[linear-fractional-transform 315 (7x + 3)/(6x + 1)]
</pre>Since I want to reason about applying a linear fractional transform to an argument, I wrote an abstraction for that:<br />
<pre>;; Apply LFT foo to continued fraction phi.
1 ]=> (make-lft-application foo phi)
;Value 311: #[lft-application 311 (3x + 1)/(x + 4) {1 ...}]
</pre>So now we can write a procedure that takes an application, peels off the first term in the continued fraction, feeds it to the linear fractional transform, and creates a new application:<br />
<pre>(define (application/step lft-application)
(let ((lft (application-function lft-application))
(cf (application-continued-fraction lft-application)))
(make-lft-application
(lft/partly-apply lft (head cf))
(tail cf))))
1 ]=> (define appl (make-lft-application lft/identity sqrt-two))
;Value: appl
1 ]=> appl
;Value 317: #[lft-application 317 x {1 2 2 2 ...}]
1 ]=> (application/step appl)
;Value 318: #[lft-application 318 (x + 1)/x {2 2 2 ...}]
1 ]=> (application/step (application/step appl))
;Value 319: #[lft-application 319 (3x + 1)/(2x + 1) {2 2 ...}]
1 ]=> (application/step (application/step (application/step appl)))
;Value 320: #[lft-application 320 (7x + 3)/(5x + 2) {2 ...}]
</pre>All these <code>lft-application</code> objects should be (numerically) equal.<br />
<br />
In an earlier post I showed how a linear fractional transform can be partly evaluated by determining the <code>integer-part</code> of the transform. The <code>integer-part</code> of an application is the <code>integer-part</code> of the application-function. You can get the fractional part by subtracting the integer-part.<br />
<hr /><h3>A digression</h3>If you apply a linear fractional transform to zero, it's obvious the answer is <code>B/D</code>. On the other hand, if you apply a transform to a sufficiently large x, you'll get as close as you want to <code>A/C</code>.<br />
<br />
If the denominator of a linear fractional transform is zero for some value of x, there should be a vertical asymptote at that point. That's the <i>pole</i> of the transform. The pole is at <code>(- D)/C</code>. The pole will be at zero if <code>D</code> is zero. It will be at a negative number if D and C are the same sign and at a positive number if D and C differ in sign.<br />
<br />
If you take a linear fractional transform with a pole at a negative number, and you sweep the input from 0 up on to infinity, the output will vary smoothly and monotonically from <code>B/D</code> approaching <code>A/C</code> and staying between both values at all times.<br />
<pre>1 ]=> lft1
;Value 675: #[linear-fractional-transform 675 (3x + 1)/(4x + 2)]
1 ]=> (lft1 0)
;Value: 1/2
1 ]=> (lft1 1000000)
;Value: 3000001/4000002
1 ]=> (exact->inexact 3000001/4000002)
;Value: .7499998750000625
</pre><br />
(On the other hand, if the pole is at a positive number, as you sweep the input from 0 up to infinity, the output starts at <code>B/D</code>, but flees away from <code>A/C</code> until the input gets to the pole. Then the output approaches <code>A/C</code>, but from the opposite direction. In any case, if the pole is positive, then the output will vary from <code>B/D</code> and eventually approach <code>A/C</code>, but <i>never</i> being between them.)<br />
<br />
We can represent intervals as linear fractional transforms. The endpoints of the interval are <code>A/C</code> and <code>B/D</code>.<br />
<br />
To get the width of the interval, just subtract the endpoints: <code>A/C - B/D = (A*D - B*C)/(C * D)</code><br />
<br />
<hr />Imagine you are performing some calculation with continued fractions. Since there may be an infinite number of terms, the calculation will proceed incrementally, using up terms as needed and generating other terms. So you can think of a more complex calculation as a tree, where a node in the tree is a linear fractional transform and the continued fraction terms flow between the nodes.<br />
<br />
When we do an <code>application/step</code>, we move a term from the continued fraction into the linear fractional transform. Now consider a term as an element of information. We've moved this information out of the continued fraction and into the linear fractional transform. The information is apparently "stored" in the linear fractional transform until it is extracted as an output term for the next stage in the computation. But if you think about it, the "format" of the information is different depending upon whether it is flowing between nodes, where it is a series of continued fraction terms, or if it is stored in a linear fractional transform, where it is encoded somehow in the values of the coefficients. The act of partly-evaluating a linear fractional transform is in effect "encoding" some information as a continued fraction term. Partly applying a linear fractional transform is in effect "decoding" the continued fraction term (presumably generated by an earlier computation). Why not change to a more efficient communication channel?<br />
<br />
When a node sends information to another node, instead of converting the information to several continued fraction terms to be assembled at the other end, we'll send the information as a single linear fractional transform. It contains the desired information already in the right "format". (See <a href="http://www.peterpotts.com/arithmetic.html">Peter Potts's</a> work.)<br />
<br />
<h3>A digression</h3><br />
What happens if we compose two linear fractional transforms?<br />
<pre>(compose (lambda (x)
(/ (+ (* A x) B)
(+ (* C x) D)))
(lambda (y)
(/ (+ (* p y) q)
(+ (* r y) s))))</pre>We get<br />
<pre>(lambda (x)
(/ (+ (* A (/ (+ (* p x) q)
(+ (* r x) s))) B)
(+ (* C (/ (+ (* p x) q)
(+ (* r x) s))) D)))</pre>Which, after some algebra, turns into this:<br />
<pre>(lambda (x)
(/ (+ (* (+ (* A p) (* B r)) x) (+ (* A q) (* B s)))
(+ (* (+ (* C p) (* D r)) x) (+ (* C q) (* D s)))))</pre>Which is equivalent to this:<br />
<pre>(lambda (x)
(let ((E (+ (* A p) (* B r)))
(F (+ (* A q) (* B s)))
(G (+ (* C p) (* D r)))
(H (+ (* C q) (* D s))))
(/ (+ (* E x) F)
(+ (* G x) H))))</pre>Which you can see is another linear fractional transform.<br />
<br />
If we have a linear fractional transform<br />
<pre>(lambda (x)
(/ (+ (* A x) B)
(+ (* C x) D)))</pre>It's inverse (if it has one) is:<br />
<pre>(lambda (x)
(/ (+ (* D x) (- B))
(+ (* (- C) x) A))))</pre>Which is yet another linear fractional transform. These things are everywhere.<br />
<br />
Let's see, if we have a binary operation <code>binop</code> that is<br />
<ol><li>Closed over some set, <i>i.e.</i> given any two elements of the set, the operation applied to the elements produces another element of the set. In other words, <code>binop</code> takes two arguments, returns one value, and the type of both arguments and return value are the same.</li>
<li>Associative,<i> i.e.</i> <code>(binop a (binop b c)) = (binop (binop a b) c)</code></li>
<li>Has an identity argument. A "left identity" is an argument such that <code>(binop left-identity x) = x</code>. A "right identity" is an argument such that <code>(binop x right-identity) = x</code>. An "identity" argument works as a left or right identity.</li>
<li>Is invertible, <i>i.e.</i> for any objects a and b, there is a unique object x such that <code>(binop a x) = b</code> and a unique object y such that <code>(binop y b) = a</code><br />
<br />
</li></ol>then we have a <a href="https://en.wikipedia.org/wiki/Group_(mathematics)"><i>group</i></a>.<br />
<br />
The <code>compose</code> function is a binary operation. When you compose a linear fractional transform with another, you get a third linear fractional transform.<pre>1 ]=> (define lft1 (make-linear-fractional-transform 3 1 4 2))
;Value: lft1
1 ]=> (define lft2 (make-linear-fractional-transform 5 1 1 0))
;Value: lft2
1 ]=> (lft/compose lft1 lft2)
;Value 662: #[linear-fractional-transform 662 (16x + 3)/(22x + 4)]
</pre>Linear fractional transforms are associative.<br />
<pre>1 ]=> (define lft3 (make-linear-fractional-transform 7 2 1 3))
;Value: lft3
1 ]=> (lft/compose lft1 (lft/compose lft2 lft3))
;Value 663: #[linear-fractional-transform 663 (115x + 41)/(158x + 56)]
1 ]=> (lft/compose (lft/compose lft1 lft2) lft3)
;Value 664: #[linear-fractional-transform 664 (115x + 41)/(158x + 56)]
</pre>The linear fractional transform <code>(make-linear-fractional-transform 1 0 0 1)</code> is both a left and right identity when composed with another linear fractional transform.<br />
<pre>1 ]=> (define lft/identity (make-linear-fractional-transform 1 0 0 1))
;Value: lft/identity
1 ]=> (lft/compose lft/identity lft1)
;Value 665: #[linear-fractional-transform 665 (3x + 1)/(4x + 2)]
1 ]=> (lft/compose lft1 lft/identity)
;Value 666: #[linear-fractional-transform 666 (3x + 1)/(4x + 2)]
</pre>Given lft1 and lft2, there is a unique linear fractional transform x such that <code>(compose lft1 x) = lft2</code>, and a unique linear fractional transform y such that <code>(compose y lft1) = lft2</code>. x should be <code>(compose (inverse lft1) lft2)</code>, and y should be <code>(compose lft2 (inverse lft1))</code><br />
<pre>1 ]=> lft1
;Value 675: #[linear-fractional-transform 675 (3x + 1)/(4x + 2)]
1 ]=> lft2
;Value 687: #[linear-fractional-transform 687 (5x + 1)/x]
1 ]=> (define x (lft/compose (lft/inverse lft1) lft2)))
;Value: x
1 ]=> (lft/compose lft1 x)
;Value 690: #[linear-fractional-transform 690 (5x + 1)/x]
1 ]=> (define y (lft/compose lft2 (lft/inverse lft1)))
;Value: y
1 ]=> (lft/compose y lft1)
;Value 691: #[linear-fractional-transform 691 (5x + 1)/x]
</pre>It sure looks like linear fractional transforms form a group under<a href="https://en.wikipedia.org/wiki/Function_composition"> function composition</a>.<br />
I guess it's time to learn a little group theory.Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-4210215842605104262014-09-22T16:49:00.000-07:002014-09-22T16:49:12.276-07:00A couple more homographic function tricksA generalized continued fraction is an expression of the form:<div class="separator" style="clear: both; text-align: center;"><a href="http://2.bp.blogspot.com/-TGpn92oyb8A/VCBjQ2v4XvI/AAAAAAAAIbM/vpf1mflAojA/s1600/GeneralizedContinuedFraction.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://2.bp.blogspot.com/-TGpn92oyb8A/VCBjQ2v4XvI/AAAAAAAAIbM/vpf1mflAojA/s1600/GeneralizedContinuedFraction.png" /></a></div>You can partly apply a homographic function to a generalized continued fraction if you have a stream of the a<sub>i</sub> and b<sub>i</sub><br />
<pre>(define (partly-apply-general hf nums dens)
(let ((a (first hf))
(b (second hf))
(c (third hf))
(d (fourth hf)))
(if (empty-stream? nums)
(values (list a a
c c)
nums
dens)
(let ((num (head nums))
(den (head dens)))
(values (list (+ (* a den) (* b num)) a
(+ (* c den) (* d num)) c)
(tail nums)
(tail dens))))))
(define (print-hf-general hf nums dens)
(call-with-values (lambda () (partly-evaluate hf))
(lambda (term hf*)
(if (not term)
(call-with-values (lambda () (partly-apply-general hf nums dens))
print-hf-general)
(begin
(display term)
;; take reciprocal and multiply by 10
(let ((a (first hf*))
(b (second hf*))
(c (third hf*))
(d (fourth hf*)))
(print-hf-general (list (* c 10) (* d 10)
a b)
nums dens)))))))
</pre>For example, we can compute pi from this generalized continued fraction:<br />
<div class="separator" style="clear: both; text-align: center;"><a href="http://3.bp.blogspot.com/-XCi6eHARuRw/VCBm410QgHI/AAAAAAAAIbY/Hzzw585xGD8/s1600/pi.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://3.bp.blogspot.com/-XCi6eHARuRw/VCBm410QgHI/AAAAAAAAIbY/Hzzw585xGD8/s1600/pi.png" /></a></div><pre>(print-hf-general (list 0 4 1 0)
;; [1 1 4 9 16 25 ...]
(cons-stream 1
(let squares ((i 1))
(cons-stream (* i i) (squares (1+ i)))))
;; [1 3 5 7 9 11 ...]
(let odds ((j 1))
(cons-stream j (odds (+ j 2)))))
314159265358979323846264338327950^G
; Quit!
</pre>A <em>bi-homographic function</em> is a function of the form:<br />
<pre>(define (bi-homographic a b c d e f g h)
(lambda (x y)
(/ (+ (* a x y) (* b x) (* c y) d)
(+ (* e x y) (* f x) (* g y) h))))
</pre>Like a homographic function, you can partly evaluate a bi-homographic function and generate a continued fraction. You can also partly apply a bi-homographic function to a pair of continued fractions. When you do this, you have a choice of which continued fraction to be the object of the partial application. There's about twice as much nasty math involved, but the gist is that a bi-homographic function takes two continued fractions as arguments and produces one continued fraction as a result.<br />
<br />
It turns out that addition, subtraction, multiplication and division are bi-homographic functions, so one can incrementally compute sums and products of continued fractions.Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-64223281510068971952014-09-18T12:06:00.000-07:002014-09-18T12:06:52.431-07:00A useful, if somewhat pointless, trick with homographic functionsIn my previous posts I showed that if you are applying a homographic function to a continued fraction, you can partly evaluate the answer before you completely apply the function. Instead of representing homographic functions as lambda expressions, I'll represent them as a list of the coefficients <code>a</code>, <code>b</code>, <code>c</code>, and <code>d</code> in <code>(lambda (t) (/ (+ (* a t) b) (+ (* c t) d)))</code>. I'll represent a simple continued fraction as a stream of the integer terms in the denominators.<br />
Here is how you partly apply a homographic function to a continued fraction:<br />
<pre>(define (partly-apply hf cf)
(let ((a (first hf))
(b (second hf))
(c (third hf))
(d (fourth hf)))
(if (empty-stream? cf)
(values (list a a
c c)
cf)
(let ((term (head cf)))
(values (list (+ (* a term) b) a
(+ (* c term) d) c)
(tail cf))))))</pre>Partly evaluating a homographic function involves looking at the limits of the function as <code>t</code> starts at 1 and goes to infinity:<br />
<pre>(define (partly-evaluate hf)
(let ((a (first hf))
(b (second hf))
(c (third hf))
(d (fourth hf)))
(if (and (same-sign? c (+ c d))
(let ((limit1 (quotient a c))
(limit2 (quotient (+ a b) (+ c d))))
(= limit1 limit2)))
(let ((term (quotient a c)))
(let ((new-c (- a (* c term)))
(new-d (- b (* d term))))
(values term (list c d new-c new-d))))
(values #f #f))))
</pre>We can combine these two steps and make something useful. For example, we can print the value of applying a homographic function to a continued fraction incrementally, printing the most significant digits before computing further digits.<br />
<pre>(define (print-hf-cf hf cf)
(call-with-values (lambda () (partly-evaluate hf))
(lambda (term hf*)
(if (not term)
(call-with-values (lambda () (partly-apply hf cf))
print-hf-cf)
(begin
(display term)
;; take reciprocal and multiply by 10
(let ((a (first hf*))
(b (second hf*))
(c (third hf*))
(d (fourth hf*)))
(print-hf-cf (list (* c 10) (* d 10)
a b)
cf)))))))</pre>But how often are you going to apply a homographic function to a continued fraction? Fortunately, the identity function is homographic (coefficients are 1 0 0 1), so applying it to a continued fraction doesn't change the value. The square root of 2 is a simple continued fraction with coefficients [1 2 2 2 ...] where the 2s repeat forever. We apply the identity homographic function to it and print the results:<br />
<pre>(printcf (list 1 0 0 1) sqrt-two)
14142135623730950488016887242096980785696718^G
; Quit!</pre>As you can see, we start printing the square root of two and we don't stop printing digits until the user interrupts.<br />
<br />
A fancier version could truncate the output and print a decimal point after the first iteration.Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-86027107704602338222014-09-05T07:53:00.000-07:002014-09-05T07:53:49.776-07:00Another stupid homographic function trickIn my last post I showed that if you take a homographic function and apply it to a fraction, you can <em>partly</em> apply the function to the integer part of the fraction and get a new homographic function. The new function can be applied to the non-integer part of the fraction to generate an answer equivalent to the original function applied to the original fraction.<br />
<br />
It turns out that you can go in the other direction as well. You can <em>partly</em> evaluate a homographic function. For example, consider this homographic function:<br />
<pre>((lambda (t)
(/ (+ (* 70 t) 29)
(+ (* 12 t) 5))) n)</pre>Which we intend to apply to some positive number <code>n</code>. Even if all we know is that <code>n</code> is positive, we can deduce that the value of the homographic function is between 29/5 (when <code>t</code> is 0) and 70/12 (as <code>t</code> goes to infinity). The integer part of those values are the same, so we can factor that out:<br />
<pre>(+ 5 (/ 1 ((lambda (t)
(/ (+ (* 12 t) 5)
(+ (* 10 t) 4))) n)))</pre>The partial answer has an integer value of 5 and a fractional part that contains a new homographic function applied to our original <code>n</code>. We can do it again:<br />
<pre>(+ 5 (/ 1
(+ 1 (/ 1
((lambda (t)
(/ (+ (* 10 t) 4)
(+ (* 2 t) 1))) n)))))</pre>The fractional part of the answer can itself be factored into another integer and a new homographic function applied to our original <code>n</code>.<br />
<br />
<a name='more'></a>A <em>generalized continued fraction</em> is a number of the form:<br />
<div class="separator" style="clear: both; text-align: center;"><a href="http://1.bp.blogspot.com/-u2oG7oTJhts/VAYioSZ8hII/AAAAAAAAIWM/EiZwhAetX90/s1600/continuedf.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://1.bp.blogspot.com/-u2oG7oTJhts/VAYioSZ8hII/AAAAAAAAIWM/EiZwhAetX90/s1600/continuedf.png" /></a></div>If all the <em>b<sub>i</sub></em> are 1, then it is a <em>simple</em> continued fraction. You can turn generalized continued fractions into a simple continued fraction by doing the algebra.<br />
<br />
What happens if you partly apply a homographic function to a continued fraction? The algebra is tedious, but here's what happens:<br />
<pre>((lambda (t)
(/ (+ (* 2 t) 1)
(+ (* 1 t) 3))) (+ 3 (/ 1 (+ 7 (/ 1 16)))))
;; after one step
((lambda (t)
(/ (+ (* 7 t) 2)
(+ (* 6 t) 1))) (+ 7 (/ 1 16)))
;; after two steps
((lambda (t)
(/ (+ (* 51 t) 7)
(+ (* 43 t) 6))) 16)
</pre>By partly apply a homographic function to a continued fraction, we can process the integer part separately and before the fractional part. By partly evaluating the application of a homographic function, we can often determine the integer part without fully evaluating the argument to the function. For example, after step one above, we could instead partially evaluate the application:<br />
<pre>;; after one step
((lambda (t)
(/ (+ (* 7 t) 2)
(+ (* 6 t) 1))) (+ 7 (/ 1 16)))
;; Alternatively, partially evaluate first term
(+ 1 (/ 1
((lambda (t)
(/ (+ (* 6 t) 1)
(+ (* 1 t) 1))) (+ 7 (/ 1 16)))))
</pre>Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-56868209233937256862014-09-03T10:32:00.000-07:002014-09-03T10:32:03.820-07:00Stupid homographic function trickA function of the form<br />
<div class="separator" style="clear: both; text-align: center;"><a href="http://1.bp.blogspot.com/-Rcot2E2rBz4/VAYCfooXuNI/AAAAAAAAIV8/yHOz_V6D6mU/s1600/homographic.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://1.bp.blogspot.com/-Rcot2E2rBz4/VAYCfooXuNI/AAAAAAAAIV8/yHOz_V6D6mU/s1600/homographic.png" /></a></div><div>is called a <i>homographic function</i>. Here is one in Scheme:<br />
<pre>(lambda (t)
(/ (+ (* 3 t) 4)
(+ (* 5 t) 2)))</pre>And here is what it's graph looks like:<div class="separator" style="clear: both; text-align: center;"><a href="http://4.bp.blogspot.com/-T310zUsYfFc/VAcudW5XENI/AAAAAAAAIYY/Mg7033nexVE/s1600/homograph.png" imageanchor="1" style="margin-left: 1em; margin-right: 1em;"><img border="0" src="http://4.bp.blogspot.com/-T310zUsYfFc/VAcudW5XENI/AAAAAAAAIYY/Mg7033nexVE/s1600/homograph.png" /></a></div>If you multiply all the coefficients (<code>a</code>, <code>b</code>, <code>c</code>, and <code>d</code>) by the same number, it doesn't change the function. For instance, this homographic function:<br />
<pre>(lambda (t)
(/ (+ (* 21 t) 28)
(+ (* 35 t) 14)))</pre>is the same as the one above. If one of your coefficients isn't an integer, don't worry, you can multiply everything by the denominator and get an equivalent homographic function. On the other hand, you can divide all your coefficients by their greatest common divisor and get an equivalent homographic function with smaller coefficients. We'll keep our homographic functions in smallest integer form.<br />
<br />
A rational number can be written as the sum of an integer and a fraction less than one. For example, 23/5 = 4 + 3/5.<br />
<br />
Let's apply a homographic function to a rational number:<br />
<pre>((lambda (t)
(/ (+ (* a t) b)
(+ (* c t) d))) (+ x y/z))
;; substitute
(/ (+ (* a (+ x y/z)) b)
(+ (* c (+ x y/z)) d))
;; distribute the multiplication
(/ (+ (* a x) (* a y/z) b)
(+ (* c x) (* c y/z) d))
;; multiply top and bottom by z/y
(/ (* z/y (+ (* a x) (* a y/z) b))
(* z/y (+ (* c x) (* c y/z) d)))
;; distribute the multiplication
(/ (+ (* a x z/y) (* a y/z z/y) (* b z/y))
(+ (* c x z/y) (* c y/z z/y) (* d z/y)))
;; simplify
(/ (+ (* a x z/y) a (* b z/y))
(+ (* c x z/y) c (* d z/y)))
;; rearrange terms
(/ (+ (* a x z/y) (* b z/y) a)
(+ (* c x z/y) (* d z/y) c))
;; factor out z/y
(/ (+ (* (+ (* a x) b) z/y) a)
(+ (* (+ (* c x) d) z/y) c))
</pre>Now we do something tricky. We abstract out the <code>z/y</code> term:<br />
<pre>((lambda (t)
(/ (+ (* (+ (* a x) b) t) a)
(+ (* (+ (* c x) d) t) c))) (/ z y))
</pre>If introduce a <code>let</code> form, we can see something interesting:<br />
<pre>((lambda (t)
(let ((a1 (+ (* a x) b))
(b1 a)
(c1 (+ (* c x) d))
(d1 c))
(/ (+ (* a1 t) b1)
(+ (* c1 t) d1)))) (/ z y))
</pre>We find a new homographic function being applied to a new rational number. The new homographic function has coefficients related to the original one, and the new rational number is the reciprocal of the fractional part of the original rational number. So if we have a homographic function <code>hf</code> applied to a fraction of the form <code>x + y/z</code>, we can easily find a new homographic function <code>hf'</code> that when applied to <code>z/y</code> will produce the same answer as the original. Applying a homographic function to a fraction has the effect of "eating" the integer part of the fraction, which generates a new homographic function that is applied to the reciprocal of the fractional part.</div><br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-39786235858640144032014-08-27T10:30:00.000-07:002014-08-28T17:06:37.232-07:00A use of Newton's methodI've seen more than one book claim that computing with real numbers inevitably involves round-off errors because real numbers can have an infinite number of digits after the decimal point and no finite representation can hold them. This is false. Instead of representing a real number as a nearby rational number with an error introduced by rounding, we'll represent a real number as computer program that generates the digits. The number of digits generated is potentially infinite, but the program that generates them is definitely finite.<br />
<br />
Here is Gosper's algorithm for computing the square root of a rational number.<br />
<pre>(define (gosper-sqrt a b c d)
;; Solve for
;; ax + b
;; ------ = x
;; cx + d
(define (newtons-method f f-prime guess)
(let ((dy (f guess)))
(if (< (abs dy) 1)
guess
(let ((dy/dx (f-prime guess)))
(newtons-method f f-prime (- guess (/ dy dy/dx)))))))
(define (f x)
(+ (* c x x)
(* (- d a) x)
(- b)))
(define (f-prime x)
(+ (* 2 c x)
(- d a)))
(let ((value (floor (newtons-method f f-prime b))))
(cons-stream value
(gosper-sqrt (+ (* c value) d)
c
(+ (* (- a (* value c)) value)
(- b (* value d)))
(- a (* value c))))))
1 ]=> (cf:render (gosper-sqrt 0 17 10 0))
1.303840481040529742916594311485836883305618755782013091790079369...
;; base 10, 100 digits
1 ]=> (cf:render (gosper-sqrt 0 17 10 0) 10 100)
1.303840481040529742916594311485836883305618755782013091790079369896765385576397896545183528886788497...
</pre>
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-16895801407690061192014-08-26T13:33:00.000-07:002014-08-26T13:33:16.234-07:00Solutions in search of problemsSuppose you have a function like <code>(define foo (lambda (x) (- (* x x x) 30)))</code> and you want to find <code>x</code> such that <code>(foo x)</code> = <code>0</code>. There are a few ways to go about this. If you can find two different <code>x</code> such that <code>(foo x)</code> is positive for one and negative for the other, then <code>(foo x)</code> must be zero somewhere in between. A simple binary search will find it.<br />
<pre>(define (bisection-method f left right)
(let* ((midpoint (average left right))
(fmid (f midpoint)))
(if (< (abs fmid) 1e-8)
midpoint
(let ((fl (f left))
(fr (f right)))
(cond ((same-sign? fl fr) (error "Left and right not on opposite sides."))
((same-sign? fmid fr) (bisection-method f left midpoint))
((same-sign? fl fmid) (bisection-method f midpoint right))
(else (error "shouldn't happen")))))))
(define (average l r) (/ (+ l r) 2))
(define (same-sign? l r)
(or (and (positive? l)
(positive? r))
(and (negative? l)
(negative? r))))
1 ]=> (cos 2)
;Value: -.4161468365471424
1 ]=> (cos 1)
;Value: .5403023058681398
1 ]=> (bisection-method cos 1.0 2.0)
1. 2.
1.5 2.
1.5 1.75
1.5 1.625
1.5625 1.625
1.5625 1.59375
1.5625 1.578125
1.5703125 1.578125
1.5703125 1.57421875
1.5703125 1.572265625
1.5703125 1.5712890625
1.5703125 1.57080078125
1.570556640625 1.57080078125
1.5706787109375 1.57080078125
1.57073974609375 1.57080078125
1.570770263671875 1.57080078125
1.5707855224609375 1.57080078125
1.5707931518554687 1.57080078125
1.5707931518554687 1.5707969665527344
1.5707950592041016 1.5707969665527344
1.570796012878418 1.5707969665527344
1.570796012878418 1.5707964897155762
1.570796251296997 1.5707964897155762
1.570796251296997 1.5707963705062866
1.5707963109016418 1.5707963705062866
1.5707963109016418 1.5707963407039642
;Value: 1.570796325802803</pre>Rather than selecting the midpoint between the two prior guesses, you can pretend that your function is linear between the guesses and interpolate where the zero should be. This can converge quicker.<br />
<pre>(define (secant-method f x1 x2)
(display x1) (display " ") (display x2) (newline)
(let ((f1 (f x1))
(f2 (f x2)))
(if (< (abs f1) 1e-8)
x1
(let ((x0 (/ (- (* x2 f1) (* x1 f2))
(- f1 f2))))
(secant-method f x0 x1)))))
1 ]=> (secant-method cos 0.0 4.0)
0. 4.
2.418900874126076 0.
1.38220688493168 2.418900874126076
1.5895160570280047 1.38220688493168
1.5706960159120333 1.5895160570280047
1.5707963326223677 1.5706960159120333
;Value: 1.5707963326223677
</pre>If you know the derivative of <code>f</code>, then you can use Newton's method to find the solution.<br />
<pre>(define (newtons-method f f-prime guess)
(display guess) (display " ") (newline)
(let ((dy (f guess)))
(if (< (abs dy) 1e-8)
guess
(let ((dy/dx (f-prime guess)))
(newtons-method f f-prime (- guess (/ dy dy/dx)))))))
1 ]=> (newtons-method cos (lambda (x) (- (sin x))) 2.0)
2.
1.5423424456397141
1.5708040082580965
1.5707963267948966
;Value: 1.5707963267948966</pre>Here's another example. We'll find the cube root of 30 by solving <code>(lambda (x) (- (* x x x) 30))</code>.<br />
<pre>(define (cube-minus-thirty x) (- (* x x x) 30))
1 ]=> (bisection-method cube-minus-thirty 0.0 4.0)
0. 4.
2. 4.
3. 4.
3. 3.5
3. 3.25
3. 3.125
3.0625 3.125
3.09375 3.125
3.09375 3.109375
3.1015625 3.109375
3.10546875 3.109375
3.10546875 3.107421875
3.1064453125 3.107421875
3.10693359375 3.107421875
3.107177734375 3.107421875
3.107177734375 3.1072998046875
3.107177734375 3.10723876953125
3.107208251953125 3.10723876953125
3.1072235107421875 3.10723876953125
3.1072311401367187 3.10723876953125
3.1072311401367187 3.1072349548339844
3.1072311401367187 3.1072330474853516
3.107232093811035 3.1072330474853516
3.107232093811035 3.1072325706481934
3.1072323322296143 3.1072325706481934
3.107232451438904 3.1072325706481934
3.107232451438904 3.1072325110435486
3.107232481241226 3.1072325110435486
3.1072324961423874 3.1072325110435486
3.107232503592968 3.1072325110435486
3.107232503592968 3.1072325073182583
3.107232505455613 3.1072325073182583
3.107232505455613 3.1072325063869357
;Value: 3.1072325059212744
1 ]=> (secant-method cube-minus-thirty 0.0 4.0)
0. 4.
1.875 0.
8.533333333333333 1.875
2.1285182547245376 8.533333333333333
2.341649751209406 2.1285182547245376
3.4857887202177547 2.341649751209406
3.0068542655016235 3.4857887202177547
3.0957153766467633 3.0068542655016235
3.1076136741672546 3.0957153766467633
3.1072310897513415 3.1076136741672546
3.1072325057801455 3.1072310897513415
;Value: 3.1072325057801455
1 ]=> (define (cube-minus-thirty-prime x) (* 3 x x))
1 ]=> (newtons-method cube-minus-thirty cube-minus-thirty-prime 4.0)
4.
3.2916666666666665
3.1173734622300557
3.10726545916981
3.1072325063033337
3.107232505953859
;Value: 3.107232505953859</pre><br />
<br />
<br />
<br />
<br />
<br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-90508265448404191292014-08-22T15:57:00.000-07:002014-08-22T15:57:14.779-07:00Small puzzle solutionBefore I give my solution, I'd like to describe the leftmost digit algorithm in a bit more detail.<br />
<pre>(define (leftmost-digit base n)
(if (< n base)
n
(let ((leftmost-pair (leftmost-digit (* base base) n)))
(if (< leftmost-pair base)
leftmost-pair
(quotient leftmost-pair base)))))</pre>The idea is this: if we have a one digit number, we just return it, otherwise we recursively call <code>leftmost-digit</code> with the <em>square</em> of the base. Squaring the base will mean gobbling up pairs of digits in the recursive call, so we'll get back either a one or two digit answer from the recursion. If it is one digit, we return it, otherwise it's two digits and we divide by the base to get the left one.<br />
<br />
For example, if our number is 12345678 and the base is 10, we'll make a recursive call with base 100. The recursive call will deal with number as if it were written <code>12 34 56 78</code> in base 100 and return the answer 12. Then we'll divide that by 10 to get the 1.<br />
<br />
Since we're squaring the base, we're doubling the number of digits we're dealing with on each recursive call. This leads to the solution in O(log log n) time. If we instrument <code>quotient</code>, you can see:<br />
<pre>(leftmost-digit 10 816305093398751331727331379663195459013258742431006753294691576)
816305093398751331727331379663195459013258742431006753294691576 / 100000000000000000000000000000000
8163050933987513317273313796631 / 10000000000000000
816305093398751 / 100000000
8163050 / 10000
816 / 100</pre>A sixty-three digit number trimmed down to one digit with only five divisions.<br />
<br />
So a simple solution to the puzzle is:<br />
<pre>(define (leftmost-digit+ base n)
(if (< n base)
(values n 0)
(call-with-values (lambda () (leftmost-digit+ (* base base) n))
(lambda (leftmost-pair count)
(if (< leftmost-pair base)
(values leftmost-pair (* count 2))
(values (quotient leftmost-pair base) (+ (* count 2) 1)))))))
</pre>The second value is the count of how many digits we discard. If the number is less than the base, we return it and we discarded nothing. Otherwise, we make the recursive call with the base squared and get back two values, the leftmost pair and the number of pairs it discarded. If the leftmost pair is a single digit, we return it, otherwise we divide by the base. The number of digits discarded is simply twice the number discarded by the recursive call, plus one more if we had to divide.<br />
<br />
But I don't see an easy way to separate finding the digit from finding the position. At first it seemed straightforward to just count the digits being discarded, but you can't decide whether to increment the count at each stage without determining if the leftmost part of the recursive call contains one or two digits.Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-82430748540620772202014-08-21T16:43:00.000-07:002014-08-21T16:43:14.348-07:00Just a small puzzleYou can get the most significant digit (the leftmost) of a number pretty quickly this way<br />
<pre>(define (leftmost-digit base n)
(if (< n base)
n
(let ((leftmost-pair (leftmost-digit (* base base) n)))
(if (< leftmost-pair base)
leftmost-pair
(quotient leftmost-pair base)))))</pre>The puzzle is to adapt this code to return the position of the leftmost digit.<br />
<br />
<pre>(leftmost-digit+ 10 46729885) would return two values, 4 and 7</pre>Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-82910414973289460562014-08-08T14:56:00.001-07:002014-08-08T14:56:44.932-07:00Mini regex golf 3: set coverI'm computing the set cover by incrementally adding items to be covered. Naturally, the order in which you add items changes the way the program progresses. I added code that picks an item to be added each iteration rather than just pulling the <code>car</code> off the front of a list.<br />
<pre>(define (cover8 value->keys-table better-solution)
(define (add-v-k-entry solution-set v-k-entry)
(let ((value (car v-k-entry))
(keys (cdr v-k-entry)))
(write-string "Adding value ") (write value) (newline)
(write-string " with keys ") (write keys) (newline)
(write-string " to ") (write (length solution-set))
(write-string " partial solutions.") (newline)
(let ((new-solutions
(map make-new-solution (cartesian-product solution-set keys))))
(let ((trimmed-solutions
(trim-partial-solutions value->keys-table new-solutions)))
(write-string "Returning ") (write (length trimmed-solutions))
(write-string " of ") (write (length new-solutions))
(write-string " new partial solutions.") (newline)
trimmed-solutions))))
(define (cover v-k-entries)
(cond ((pair? v-k-entries)
(pick-v-k-entry value->keys-table v-k-entries
(lambda (selected remaining)
(add-v-k-entry (cover remaining) selected))))
((null? v-k-entries)
(list '()))
(else (improper-list-error 'cover v-k-entries))))
(let ((minimized (minimize-vktable value->keys-table better-solution)))
(least-elements (cover minimized) better-solution)))
(define (pick-v-k-entry value->keys-table v-k-entries receiver)
(define (score v-k-entry)
(let* ((matched-all
(count-matching-items value->keys-table
(lambda (other)
(there-exists? (cdr v-k-entry)
(lambda (key) (member key (cdr other)))))))
(matched-remaining
(count-matching-items v-k-entries
(lambda (other)
(there-exists? (cdr v-k-entry)
(lambda (key) (member key (cdr other)))))))
(matched-forward (- matched-all matched-remaining)))
(cons matched-remaining matched-forward)))
(let ((scored (map (lambda (v-k-entry) (cons (score v-k-entry) v-k-entry))
v-k-entries)))
(let ((picked
(cdar
(least-elements scored
(lambda (left right)
(let* ((len-l (length (cdr left)))
(len-r (length (cdr right)))
(lmr (caar left))
(lmf (cdar left))
(rmr (caar right))
(rmf (cdar right)))
(or (> len-l len-r)
(and (= len-l len-r)
(or (> lmf rmf)
(and (= lmf rmf)
(< lmr rmr)))))
))))))
(display "Picking ") (write picked) (newline)
(receiver picked (delete picked v-k-entries)))))
(define (trim-partial-solutions value->keys-table partial-solutions)
(let ((equivalent-solutions
(map (lambda (entry) (cons (cdr entry) (car entry)))
(collect-equivalent-partial-solutions value->keys-table
partial-solutions))))
(write-string " Deleting ")
(write (- (length partial-solutions) (length equivalent-solutions)))
(write-string " equivalent partial solutions.")
(newline)
(remove-dominated-solutions value->keys-table
(map lowest-scoring-equivalent-partial-solution
equivalent-solutions))))
</pre>Finally, it turns out that computing dominating partial solutions is expensive, so I changed the set operations to use a bitmap representation:<pre>(define (remove-dominated-solutions value->keys-table partial-solutions)
(let ((before-length (length partial-solutions))
(all-values (get-values value->keys-table)))
(let ((table
;; put the long ones in first
(sort
(map (lambda (partial-solution)
(cons partial-solution
(lset->bset all-values
(map car (partial-solution-matches value->keys-table
partial-solution)))))
partial-solutions)
(lambda (left right)
(> (length (bset->lset all-values (cdr left)))
(length (bset->lset all-values (cdr right))))))))
(let ((answer (map car
(fold-left (lambda (answer solution)
(if (there-exists? answer
(dominates-solution? solution))
answer
(cons solution answer)))
'()
table))))
(let ((after-length (length answer)))
(write-string " Removing ") (write (- before-length after-length))
(write-string " dominated solutions.")
(newline)
answer)))))
(define (dominates-solution? solution)
(let* ((partial-solution (car solution))
(partial-solution-score (score partial-solution))
(solution-matches-raw (cdr solution)))
(lambda (other-solution)
(let* ((other-partial-solution (car other-solution))
(other-matches-raw (cdr other-solution)))
(and
(bset-superset? other-matches-raw solution-matches-raw)
(<= (score other-partial-solution) partial-solution-score))))))
(define (get-values v-k-table)
(fold-left (lambda (answer entry) (lset-adjoin equal? answer (car entry)))
'()
v-k-table))
(define (bset-element->bit universe element)
(cond ((null? element) 0)
(else (expt 2 (list-index (lambda (item) (eq? item element)) universe)))))
(define (bset-adjoin universe bset element)
(bset-union bset (bset-element->bit universe element)))
(define (lset->bset universe lset)
(fold-left (lambda (answer element)
(bset-adjoin universe answer element))
0
lset))
(define (bset->lset universe bset)
(cond ((zero? bset) '())
((even? bset) (bset->lset (cdr universe) (/ bset 2)))
(else (cons (car universe) (bset->lset (cdr universe) (/ (- bset 1) 2))))))
(define (bset-union left right) (bitwise-ior left right))
(define (bset-superset? bigger smaller)
;; Is every element of smaller in bigger?
(zero? (bitwise-andc2 smaller bigger)))
</pre>This code can now find the shortest regular expression consisting of letters and dots (and ^$) that matches one set of strings but not another.<br />
<br />
Depending on the strings, this can take quite a bit of time to run. Dotted expressions cause a combinatorical explosion in matching regexps (or substrings), but what makes it worse is that the dotted expressions tend to span different sets of strings. If two different dotted expressions, each with different matching sets of strings, appear in a single string, then the number of partial solutions will be multiplied by two as we try each different dotted expression.<br />
<br />
It is characteristic of NP problems that it is easy to determine if you have a good solution, but quite hard to find it among a huge number of other, poor solutions. This problem exhibits this characteristic, but there is a bit more structure in the problem that we are exploiting. The word lists are drawn from the English language. This makes some bigrams, trigrams, etc. far, far, more likely to appear than others.<br />
<br />
Short words are much easier to process than longer ones because they simply contain fewer things to match. On the other hand, longer words tend to be dominated by shorter ones anyway.<br />
<br />
To be continued...Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-5373700746004630732014-08-07T09:43:00.001-07:002014-08-07T09:43:43.533-07:00Mini regex golf 2: adding regular expressionsIt wasn't too hard to add regular expressions to the substring version. What took a while was just tinkering with the code, breaking it, fixing it again, noticing an optimization, tinkering, etc. etc. In any case it works and here is some of it.<br />
<pre>(define (make-extended-ngram-table winners losers)
(let* ((initial-ngrams (generate-ngrams winners losers)))
(write-string "Initial ngrams: ") (write (length initial-ngrams))
(newline)
(map (lambda (winner)
(cons winner
(keep-matching-items initial-ngrams
(lambda (ngram) (re-string-search-forward ngram winner)))))
winners)))
(define (generate-ngrams winners losers)
(write-string "Generating ngrams...")(newline)
(let ((losing-ngram? (string-list-matcher losers)))
(fold-left (lambda (answer winner)
(lset-union equal? answer (extended-ngrams losing-ngram? winner)))
'()
winners)))
(define (string-list-matcher string-list)
(lambda (test-ngram)
(there-exists? string-list
(lambda (string)
(re-string-search-forward test-ngram string)))))
(define *dotification-limit* 4)
(define *generate-ends-of-words* #t)
(define *generate-dotted* #t)
(define (ngrams-of-length n string)
(do ((start 0 (1+ start))
(end n (1+ end))
(answer '() (lset-adjoin string=? answer (substring string start end))))
((> end (string-length string)) answer)))
(define (generate-dotted answer losing-ngram?)
(do ((tail answer (cdr tail))
(answer '() (let ((item (car tail)))
(fold-left (lambda (answer dotted)
(if (losing-ngram? dotted)
answer
(lset-adjoin string=? answer dotted)))
answer
(dotify item)))))
((not (pair? tail))
(if (null? tail)
answer
(improper-list-error 'generate-dotted tail)))))
(define (dotify word)
(cond ((string=? word "") (list ""))
((> (string-length word) *dotification-limit*) (list word))
(else
(fold-left (lambda (answer dotified)
(fold-left (lambda (answer replacement)
(lset-adjoin equal? answer
(string-append replacement dotified)))
answer
(replacements (substring word 0 1))))
'()
(dotify (substring word 1 (string-length word)))))))
(define (replacements string)
(if (or (string=? string "^")
(string=? string "$"))
(list string)
(list string ".")))
(define (extended-ngrams losing-ngram? string)
(let ((string (if *generate-ends-of-words*
(string-append "^" string "$")
string)))
(do ((n 1 (+ n 1))
(answer '() (lset-union
string=? answer
(delete-matching-items (ngrams-of-length n string)
losing-ngram?))))
((> n (string-length string))
(if *generate-dotted*
(generate-dotted answer losing-ngram?)
answer)))))</pre>Adding the dotification greatly increases the number of ways to match words:<br />
<pre>1 ]=> (extended-ngrams (string-list-matcher losers) "lincoln")
;Value 15: ("li" "ln" "ln$" "oln" ".ln" "col" "lin" "li." "^li" "o.n$" "oln$" ".ln$" "col." "c.ln" "..ln" "coln" ".oln" "co.n" "n.ol" "..ol" "ncol" ".col" "nc.l" "i.co" "inco" "i..o" "in.o" "lin." "li.." "l.nc" "linc" "l..c" "li.c" "^li." "^lin" "coln$" "ncoln" "incol" "linco" "^linc" "ncoln$" "incoln" "lincol" "^linco" "incoln$" "lincoln" "^lincol" "lincoln$" "^lincoln" "^lincoln$")</pre>The table that maps words to their extended ngrams is quite large, but it can be reduced in size without affecting the solution to the set cover problem. If two regexps match exactly the same set of winning strings, then one can be substituted for the other in any solution, so we can discard all but the shortest of these. If a regexp matches a proper superset of another regexp, and the other regexp is at least the same length or longer, then the first regexp dominates the second one, so we can discard the second one.<br />
<pre>(define (minimize-keys value->keys-table better-solution)
(let* ((all-keys (get-keys value->keys-table))
(equivalents (collect-equivalent-partial-solutions value->keys-table
(map list all-keys)))
(reduced (map (lambda (equivalent)
(cons (car equivalent)
(car (least-elements (cdr equivalent)
better-solution))))
equivalents))
(dominants (collect-dominant-partial-solutions reduced better-solution))
(good-keys (fold-left (lambda (answer candidate)
(lset-adjoin equal? answer (cadr candidate)))
'()
dominants)))
(define (rebuild-entry entry)
(cons (car entry) (keep-matching-items (cdr entry)
(lambda (item) (member item good-keys)))))
(write-string "Deleting ") (write (- (length all-keys) (length good-keys)))
(write-string " of ") (write (length all-keys)) (write-string " keys. ")
(write (length good-keys)) (write-string " keys remain.")(newline)
(map rebuild-entry value->keys-table)))
(define (partial-solution-matches value->keys-table partial-solution)
(keep-matching-items
value->keys-table
(lambda (entry)
(there-exists? partial-solution (lambda (key) (member key (cdr entry)))))))
(define (collect-equivalent-partial-solutions value->keys-table partial-solutions)
(let ((answer-table (make-equal-hash-table)))
(for-each (lambda (partial-solution)
(hash-table/modify! answer-table
(map car (partial-solution-matches
value->keys-table
partial-solution))
(list)
(lambda (other)
(lset-adjoin equal? other partial-solution))))
partial-solutions)
(hash-table->alist answer-table)))
(define (collect-dominant-partial-solutions equivalents better-solution)
(define (dominates? left right)
(and (superset? (car left) (car right))
(not (better-solution (cdr right) (cdr left)))))
(let ((sorted (sort equivalents
(lambda (l r) (> (length (car l)) (length (car r)))))))
(fold-left (lambda (answer candidate)
(if (there-exists? answer (lambda (a) (dominates? a candidate)))
answer
(lset-adjoin equal? answer candidate)))
'()
sorted)))
</pre>We can minimize the value->key-table in another way. If two values in the table are matched by the exact same set of keys, then we can delete one without changing the solution. If a value is matched by a small set of keys, and if another values is matched by a superset of these keys, then we can delete the larger one because if the smaller one matches, the larger one must match as well.<pre>(define (minimize-values v-k-table)
(let ((size-before (length v-k-table)))
(define (dominated-value? entry)
(let ((entry-value (car entry))
(entry-keylist (cdr entry)))
(there-exists? v-k-table
(lambda (other-entry)
(and (not (eq? entry other-entry))
(let ((other-value (car other-entry))
(other-keylist (cdr other-entry)))
(let ((result (and (superset? entry-keylist other-keylist)
(not (superset? other-keylist entry-keylist)))))
(if result
(begin (display "Removing ")
(write entry-value)
(display " dominated by ")
(write other-value)
(display ".")
(newline)
))
result)))))))
(define (equivalent-value-in-answer? answer entry)
(let ((entry-value (car entry))
(entry-keylist (cdr entry)))
(there-exists? answer
(lambda (other-entry)
(let ((other-value (car other-entry))
(other-keylist (cdr other-entry)))
(let ((result (equal? entry-keylist other-keylist)))
(if result
(begin (display "Removing ")
(write entry-value)
(display " equivalent to ")
(write other-value)
(display ".")
(newline)
))
result))))))
(define (add-entry answer entry)
(if (or (equivalent-value-in-answer? answer entry)
(dominated-value? entry))
answer
(cons entry answer)))
(let ((answer (fold-left add-entry '() v-k-table)))
(write-string "Removed ") (write (- size-before (length answer)))
(write-string " dominated and equivalent values.")
(newline)
answer)))</pre>Each time we remove values or keys, we might make more keys and values equivalent or dominated, so we iterate until we can no longer remove anything.<pre>(define (minimize-vktable value->keys-table better-solution)
(let* ((before-size (fold-left + 0 (map length value->keys-table)))
(new-table
(minimize-values
(minimize-keys value->keys-table better-solution)))
(after-size (fold-left + 0 (map length new-table))))
(if (= before-size after-size)
value->keys-table
(minimize-vktable new-table better-solution))))</pre>The minimized table for the presidents looks like this:<br />
<pre>(("washington" "sh" "g..n" "n..o" ".h.n" "a..i")
("adams" "a.a" "am" "ad")
("madison" "m..i" "i..n" "is." "i.o" "di" "ma" "ad")
("monroe" "r.e$" "oe")
("van-buren" "u..n" "r.n" ".b" "bu" "-")
("harrison" "r..s" "r.i" "i..n" "is." "i.o" "a..i")
("polk" "po")
("taylor" "ay." "ta")
("pierce" "ie." "rc" "r.e$")
("buchanan" "bu" "a.a" ".h.n")
("lincoln" "i..o" "li")
("grant" "an.$" "a.t" "ra" "r.n" "g..n")
("hayes" "h..e" "ye" "ay.")
("garfield" "el.$" "i.l" "ga" "ie." "r.i" ".f" "a..i")
("cleveland" "v.l" "an.$")
("mckinley" "n.e" "nl" "i.l" "m..i")
("roosevelt" ".se" "oo" "v.l" "el.$" "r..s")
("taft" "a.t" "ta" ".f")
("wilson" "ls" "i..o")
("harding" "r.i" "di" "a..i")
("coolidge" "oo" "li")
("hoover" "ho" "oo")
("truman" "u..n" "ma")
("eisenhower" "ho" ".se" "h..e" "i..n" "is.")
("kennedy" "nn" "n.e")
("johnson" "j")
("nixon" "^n" "i..n" "i.o" "n..o")
("carter" "rt" "a.t")
("reagan" "ga" "a.a")
("bush" "bu" "sh")
("obama" ".b" "ma" "a.a" "am"))</pre>As you can see, we have reduced the original 2091 matching regexps to fifty.<br />
<br />
Changes to the set-cover code coming soon....Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-48821469937434849332014-08-01T09:49:00.000-07:002014-08-01T09:49:23.115-07:00Mini regex golfI was intrigued by Peter Norvig's articles about <a href="http://nbviewer.ipython.org/url/norvig.com/ipython/xkcd1313.ipynb">regex golf</a>.<br />
<br />
To make things easier to think about, I decided to start with the simpler problem of looking for substrings. Here's code to extract the ngrams of a string:<br />
<pre>(define (ngrams-of-length n string)
(do ((start 0 (1+ start))
(end n (1+ end))
(answer '() (lset-adjoin string=? answer (substring string start end))))
((> end (string-length string)) answer)))
(define (ngrams string)
(do ((n 1 (+ n 1))
(answer '() (append (ngrams-of-length n string) answer)))
((> n (string-length string)) answer)))</pre>A solution is simply a list of ngrams. (Although not every list of ngrams is a solution!) <br />
<pre>(define (solution? solution winners losers)
(let ((matches-solution? (ngram-list-matcher solution)))
(and (for-all? winners matches-solution?)
(not (there-exists? losers matches-solution?)))))
(define (ngram-list-matcher ngram-list)
(lambda (test-string)
(there-exists? ngram-list
(lambda (ngram)
(string-search-forward ngram test-string)))))
</pre>We also want to know if an ngram appears in a given list of strings.<br />
<pre>(define (string-list-matcher string-list)
(lambda (test-ngram)
(there-exists? string-list
(lambda (string)
(string-search-forward test-ngram string)))))
(fluid-let ((*unparser-list-breadth-limit* 10))
(let ((matches-loser? (string-list-matcher losers)))
(for-each
(lambda (winner) (write-string winner) (write-string ": ")
(write (reverse (delete-matching-items (ngrams winner) matches-loser?)))
(newline))
winners)))
washington: ("sh" "hi" "gt" "to" "was" "ash" "shi" "hin" "ngt" "gto" ...)
adams: ("ad" "am" "ms" "ada" "dam" "ams" "adam" "dams" "adams")
jefferson: ("j" "je" "ef" "ff" "fe" "rs" "jef" "eff" "ffe" "fer" ...)
madison: ("ma" "ad" "di" "mad" "adi" "dis" "iso" "madi" "adis" "diso" ...)
monroe: ("oe" "onr" "nro" "roe" "monr" "onro" "nroe" "monro" "onroe" "monroe")
jackson: ("j" "ja" "ac" "ks" "jac" "ack" "cks" "kso" "jack" "acks" ...)
van-buren: ("-" "va" "n-" "-b" "bu" "van" "an-" "n-b" "-bu" "bur" ...)
harrison: ("har" "arr" "rri" "ris" "iso" "harr" "arri" "rris" "riso" "ison" ...)
polk: ("po" "pol" "olk" "polk")
taylor: ("ta" "yl" "lo" "tay" "ayl" "ylo" "lor" "tayl" "aylo" "ylor" ...)
pierce: ("rc" "ce" "pie" "ier" "erc" "rce" "pier" "ierc" "erce" "pierc" ...)
buchanan: ("bu" "uc" "ch" "na" "buc" "uch" "cha" "ana" "nan" "buch" ...)
lincoln: ("li" "ln" "lin" "col" "oln" "linc" "inco" "ncol" "coln" "linco" ...)
grant: ("ra" "gra" "ran" "ant" "gran" "rant" "grant")
hayes: ("ye" "hay" "aye" "yes" "haye" "ayes" "hayes")
garfield: ("ga" "rf" "fi" "gar" "arf" "rfi" "fie" "iel" "eld" "garf" ...)
cleveland: ("lev" "vel" "ela" "clev" "leve" "evel" "vela" "elan" "cleve" "level" ...)
mckinley: ("nl" "mck" "inl" "nle" "mcki" "kinl" "inle" "nley" "mckin" "ckinl" ...)
roosevelt: ("oo" "os" "lt" "roo" "oos" "ose" "sev" "vel" "elt" "roos" ...)
taft: ("ta" "af" "ft" "taf" "aft" "taft")
wilson: ("ls" "ils" "lso" "wils" "ilso" "lson" "wilso" "ilson" "wilson")
harding: ("di" "har" "ard" "rdi" "din" "hard" "ardi" "rdin" "ding" "hardi" ...)
coolidge: ("oo" "li" "coo" "ool" "oli" "lid" "cool" "ooli" "olid" "lidg" ...)
hoover: ("ho" "oo" "hoo" "oov" "hoov" "oove" "hoove" "oover" "hoover")
truman: ("tr" "ru" "ma" "tru" "rum" "uma" "man" "trum" "ruma" "uman" ...)
eisenhower: ("ei" "nh" "ho" "ow" "eis" "ise" "sen" "enh" "nho" "how" ...)
kennedy: ("nn" "ed" "dy" "ken" "enn" "nne" "ned" "edy" "kenn" "enne" ...)
johnson: ("j" "jo" "oh" "hn" "joh" "ohn" "hns" "john" "ohns" "hnso" ...)
nixon: ("ni" "ix" "xo" "nix" "ixo" "xon" "nixo" "ixon" "nixon")
carter: ("rt" "car" "art" "rte" "cart" "arte" "rter" "carte" "arter" "carter")
reagan: ("ea" "ag" "ga" "rea" "eag" "aga" "gan" "reag" "eaga" "agan" ...)
bush: ("bu" "us" "sh" "bus" "ush" "bush")
clinton: ("li" "to" "cli" "lin" "int" "nto" "ton" "clin" "lint" "into" ...)
obama: ("ob" "ba" "am" "ma" "oba" "bam" "ama" "obam" "bama" "obama")
</pre>We can discard ngrams like "shi" because the shorter ngram "sh" will also match.<br />
<pre>(define (dominant-ngrams string losing-ngram?)
(do ((n 1 (+ n 1))
(answer '() (append
(delete-matching-items
(ngrams-of-length n string)
(lambda (item)
(or (there-exists? answer
(lambda (ngram)
(string-search-forward ngram item)))
(losing-ngram? item))))
answer)))
((> n (string-length string)) answer)))
(fluid-let ((*unparser-list-breadth-limit* 10))
(let ((matches-loser? (string-list-matcher losers)))
(for-each
(lambda (winner) (write-string winner) (write-string ": ")
(write (dominant-ngrams winner matches-loser?))
(newline))
winners)))
washington: ("was" "to" "gt" "hi" "sh")
adams: ("ms" "am" "ad")
jefferson: ("rs" "fe" "ff" "ef" "j")
madison: ("iso" "di" "ad" "ma")
monroe: ("nro" "onr" "oe")
jackson: ("ks" "ac" "j")
van-buren: ("ren" "ure" "bu" "va" "-")
harrison: ("iso" "ris" "rri" "arr" "har")
polk: ("olk" "po")
taylor: ("lo" "yl" "ta")
pierce: ("ier" "pie" "ce" "rc")
buchanan: ("na" "ch" "uc" "bu")
lincoln: ("inco" "col" "ln" "li")
grant: ("ant" "ra")
hayes: ("hay" "ye")
garfield: ("eld" "iel" "fi" "rf" "ga")
cleveland: ("ela" "vel" "lev")
mckinley: ("mck" "nl")
roosevelt: ("vel" "sev" "lt" "os" "oo")
taft: ("ft" "af" "ta")
wilson: ("ls")
harding: ("ard" "har" "di")
coolidge: ("li" "oo")
hoover: ("oo" "ho")
truman: ("ma" "ru" "tr")
eisenhower: ("wer" "sen" "ise" "ow" "ho" "nh" "ei")
kennedy: ("ken" "dy" "ed" "nn")
johnson: ("hn" "oh" "j")
nixon: ("xo" "ix" "ni")
carter: ("car" "rt")
reagan: ("ga" "ag" "ea")
bush: ("sh" "us" "bu")
clinton: ("int" "to" "li")
obama: ("ma" "am" "ba" "ob")
</pre>It's time to tackle the set cover problem. We want a set of ngrams that match all the strings. Obviously, if we pick an ngram from each of the strings we want to cover, we'll have a solution. For instance,<br />
<pre>(let ((matches-loser? (string-list-matcher losers)))
(solution? (delete-duplicates
(map
(lambda (winner) (car (dominant-ngrams winner matches-loser?)))
winners))
winners losers))
;Value: #t
</pre>We can cycle through all the possible solutions and then select the best one.<br />
<pre>(define (mini-golf0 winners losers)
(lowest-scoring
(cover0 (make-dominant-ngram-table
winners
(delete-losing-superstrings winners losers)))))
(define (delete-losing-superstrings winners losers)
(delete-matching-items
losers
(lambda (loser)
(there-exists? winners
(lambda (winner)
(string-search-forward winner loser))))))
(define (make-dominant-ngram-table winners losers)
(let ((losing-ngram? (string-list-matcher losers)))
(map (lambda (winner)
(cons winner (dominant-ngrams winner losing-ngram?)))
winners)))
(define (cover0 v-k-table)
(let ((empty-solution-set (list '())))
(fold-left add-v-k-entry0 empty-solution-set v-k-table)))
(define (add-v-k-entry0 solution-set v-k-entry)
(let ((value (car v-k-entry))
(keys (cdr v-k-entry)))
(write-string "Adding value ") (write value) (newline)
(write-string " with keys ") (write keys) (newline)
(write-string " to ") (write (length solution-set))
(write-string " partial solutions.") (newline)
(let ((new-solutions
(map make-new-solution (cartesian-product solution-set keys))))
(write-string "Returning ") (write (length new-solutions))
(write-string " new partial solutions.") (newline)
new-solutions)))
(define (lowest-scoring list)
(least-elements list (lambda (l r) (< (score l) (score r)))))
(define (cartesian-product left-list right-list)
(fold-left (lambda (answer left)
(fold-left (lambda (answer right)
(cons (cons left right) answer))
answer
right-list))
'()
left-list))
(define (make-new-solution cp-term)
(let ((solution (car cp-term))
(key (cdr cp-term)))
(lset-adjoin equal? solution key)))
(define (improper-list-error procedure thing)
(error (string-append "Improper list found by " procedure ": ") thing))
(define (least-elements list <)
(define (accumulate-least answer item)
(cond ((< (car answer) item) answer)
((< item (car answer)) (cons item '()))
(else (cons item answer))))
(cond ((pair? list) (fold-left accumulate-least
(cons (car list) '())
(cdr list)))
((null? list) (error "List must have at least one element." list))
(else (improper-list-error 'LEAST-ELEMENTS list))))
(define (score solution)
(do ((tail solution (cdr tail))
(score -1 (+ score (string-length (car tail)) 1)))
((not (pair? tail))
(if (null? tail)
score
(improper-list-error 'score solution)))))
</pre>
This works for small sets:
<pre>1 ]=> (mini-golf0 boys girls)
Adding value "jacob"
with keys ("ob" "c" "j")
to 1 partial solutions.
Returning 3 new partial solutions.
Adding value "mason"
with keys ("as")
to 3 partial solutions.
Returning 3 new partial solutions.
Adding value "ethan"
with keys ("an" "ha")
to 3 partial solutions.
Returning 6 new partial solutions.
Adding value "noah"
with keys ("ah" "oa" "no")
to 6 partial solutions.
Returning 18 new partial solutions.
Adding value "william"
with keys ("lia" "lli" "ill" "am" "w")
to 18 partial solutions.
Returning 90 new partial solutions.
Adding value "liam"
with keys ("lia" "am")
to 90 partial solutions.
Returning 180 new partial solutions.
Adding value "jayden"
with keys ("en" "de" "yd" "ay" "j")
to 180 partial solutions.
Returning 900 new partial solutions.
Adding value "michael"
with keys ("ae" "ha" "c")
to 900 partial solutions.
Returning 2700 new partial solutions.
Adding value "alexander"
with keys ("de" "nd" "an" "le" "al" "r" "x")
to 2700 partial solutions.
Returning 18900 new partial solutions.
Adding value "aiden"
with keys ("en" "de" "id")
to 18900 partial solutions.
Returning 56700 new partial solutions.
;Value 41: (("de" "am" "ah" "ha" "as" "j")
("de" "am" "ah" "ha" "as" "j")
("de" "am" "oa" "ha" "as" "j")
("de" "am" "oa" "ha" "as" "j")
("de" "am" "no" "ha" "as" "j")
("de" "am" "no" "ha" "as" "j")
("de" "am" "ah" "ha" "as" "c")
("de" "am" "ah" "ha" "as" "c")
("de" "am" "oa" "ha" "as" "c")
("de" "am" "oa" "ha" "as" "c")
("de" "am" "no" "ha" "as" "c")
("de" "am" "no" "ha" "as" "c")
("de" "am" "ah" "an" "as" "c")
("de" "am" "ah" "an" "as" "c")
("en" "am" "ah" "an" "as" "c")
("de" "am" "oa" "an" "as" "c")
("de" "am" "oa" "an" "as" "c")
("en" "am" "oa" "an" "as" "c")
("de" "am" "no" "an" "as" "c")
("de" "am" "no" "an" "as" "c")
("en" "am" "no" "an" "as" "c"))
</pre>But you can see that we won't be able to go much beyond this because there are just too many combinations.
We can cut down on the intermediate partial solutions by noticing that many of them are redundant. We don't need to keep partial solutions that cannot possibly lead to a shortest final solution. The various partial solutions each (potentially) match different sets of words. We only need keep the shortest solution for each different set of matched words. Furthermore, if a solution's matches are a superset of another's matches, and the other is the same length or longer, then the solution is dominated by the other and will always be at least the length of the longer.
<pre>(define (mini-golf1 winners losers)
(cover1
(make-dominant-ngram-table winners (delete-losing-superstrings winners losers))
lowest-scoring))
(define (cover1 v-k-table lowest-scoring)
(let ((empty-solution-set (list '())))
(define (add-v-k-entry solution-set v-k-entry)
(let ((value (car v-k-entry))
(keys (cdr v-k-entry)))
(write-string "Adding value ") (write value) (newline)
(write-string " with keys ") (write keys) (newline)
(write-string " to ") (write (length solution-set))
(write-string " partial solutions.") (newline)
(let ((new-solutions
(map make-new-solution (cartesian-product solution-set keys))))
(let ((trimmed-solutions (trim-partial-solutions new-solutions)))
(write-string "Returning ") (write (length trimmed-solutions))
(write-string " of ") (write (length new-solutions))
(write-string " new partial solutions.") (newline)
trimmed-solutions))))
(define (trim-partial-solutions partial-solutions)
(let ((equivalent-solutions (collect-equivalent-partial-solutions partial-solutions)))
(write-string " Deleting ")
(write (- (length partial-solutions) (length equivalent-solutions)))
(write-string " equivalent partial solutions.")
(newline)
(remove-dominated-solutions
(map lowest-scoring-equivalent-partial-solution equivalent-solutions))))
(define (lowest-scoring-equivalent-partial-solution entry)
(first (lowest-scoring (car entry))))
(define (collect-equivalent-partial-solutions alist)
;; Add each entry in turn.
(fold-left (lambda (equivalents partial-solution)
(add-equivalent-partial-solution
partial-solution
(partial-solution-matches partial-solution)
equivalents))
'() alist))
(define (partial-solution-matches partial-solution)
(keep-matching-items v-k-table
(lambda (entry)
(there-exists? partial-solution
(lambda (key) (member key (cdr entry)))))))
(define (remove-dominated-solutions partial-solutions)
(let ((before-length (length partial-solutions)))
(let ((answer (map car (fold-left (lambda (answer solution)
(if (there-exists? answer (dominates-solution? solution))
answer
(cons solution answer)))
'()
(map (lambda (partial-solution)
(cons partial-solution (partial-solution-matches partial-solution)))
partial-solutions)))))
(let ((after-length (length answer)))
(write-string " Deleting ") (write (- before-length after-length))
(write-string " dominated solutions.")
(newline)
answer))))
(lowest-scoring
(fold-left add-v-k-entry empty-solution-set v-k-table))))
(define (dominates-solution? solution)
(let ((partial-solution (car solution))
(solution-matches (cdr solution)))
(lambda (other-solution)
(let ((other-partial-solution (car other-solution))
(other-matches (cdr other-solution)))
(and (not (equal? solution-matches other-matches))
(superset? other-matches solution-matches)
(<= (score other-partial-solution) (score partial-solution)))))))
(define (add-equivalent-partial-solution solution value alist)
(cond ((pair? alist)
(let ((entry (car alist))
(tail (cdr alist)))
(let ((entry-solutions (car entry))
(entry-value (cdr entry)))
(if (equal? value entry-value)
(if (member solution entry-solutions)
alist
(cons (cons (cons solution entry-solutions) value)
tail))
(cons entry (add-equivalent-partial-solution solution value tail))))))
((null? alist) (list (cons (list solution) value)))
(else (improper-list-error 'collect-equivalents alist))))
</pre>
<pre>1 ]=> (mini-golf1 winners losers)
Adding value "washington"
with keys ("was" "to" "gt" "hi" "sh")
to 1 partial solutions.
Deleting 2 equivalent partial solutions.
Removing 1 dominated solutions.
Returning 2 of 5 new partial solutions.
Adding value "adams"
with keys ("ms" "am" "ad")
to 2 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 2 dominated solutions.
Returning 4 of 6 new partial solutions.
Adding value "jefferson"
with keys ("rs" "fe" "ff" "ef" "j")
to 4 partial solutions.
Deleting 12 equivalent partial solutions.
Removing 4 dominated solutions.
Returning 4 of 20 new partial solutions.
Adding value "madison"
with keys ("iso" "di" "ad" "ma")
to 4 partial solutions.
Deleting 2 equivalent partial solutions.
Removing 2 dominated solutions.
Returning 12 of 16 new partial solutions.
Adding value "monroe"
with keys ("nro" "onr" "oe")
to 12 partial solutions.
Deleting 24 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 12 of 36 new partial solutions.
Adding value "jackson"
with keys ("ks" "ac" "j")
to 12 partial solutions.
Deleting 24 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 12 of 36 new partial solutions.
Adding value "van-buren"
with keys ("ren" "ure" "bu" "va" "-")
to 12 partial solutions.
Deleting 36 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 24 of 60 new partial solutions.
Adding value "harrison"
with keys ("iso" "ris" "rri" "arr" "har")
to 24 partial solutions.
Deleting 96 equivalent partial solutions.
Removing 12 dominated solutions.
Returning 12 of 120 new partial solutions.
Adding value "polk"
with keys ("olk" "po")
to 12 partial solutions.
Deleting 12 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 12 of 24 new partial solutions.
Adding value "taylor"
with keys ("lo" "yl" "ta")
to 12 partial solutions.
Deleting 12 equivalent partial solutions.
Removing 12 dominated solutions.
Returning 12 of 36 new partial solutions.
Adding value "pierce"
with keys ("ier" "pie" "ce" "rc")
to 12 partial solutions.
Deleting 36 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 12 of 48 new partial solutions.
Adding value "buchanan"
with keys ("na" "ch" "uc" "bu")
to 12 partial solutions.
Deleting 39 equivalent partial solutions.
Removing 3 dominated solutions.
Returning 6 of 48 new partial solutions.
Adding value "lincoln"
with keys ("inco" "col" "ln" "li")
to 6 partial solutions.
Deleting 15 equivalent partial solutions.
Removing 6 dominated solutions.
Returning 3 of 24 new partial solutions.
Adding value "grant"
with keys ("ant" "ra")
to 3 partial solutions.
Deleting 3 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 3 of 6 new partial solutions.
Adding value "hayes"
with keys ("hay" "ye")
to 3 partial solutions.
Deleting 3 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 3 of 6 new partial solutions.
Adding value "garfield"
with keys ("eld" "iel" "fi" "rf" "ga")
to 3 partial solutions.
Deleting 9 equivalent partial solutions.
Removing 3 dominated solutions.
Returning 3 of 15 new partial solutions.
Adding value "cleveland"
with keys ("ela" "vel" "lev")
to 3 partial solutions.
Deleting 3 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 6 of 9 new partial solutions.
Adding value "mckinley"
with keys ("mck" "nl")
to 6 partial solutions.
Deleting 6 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 6 of 12 new partial solutions.
Adding value "roosevelt"
with keys ("vel" "sev" "lt" "os" "oo")
to 6 partial solutions.
Deleting 24 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 6 of 30 new partial solutions.
Adding value "taft"
with keys ("ft" "af" "ta")
to 6 partial solutions.
Deleting 12 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 6 of 18 new partial solutions.
Adding value "wilson"
with keys ("ls")
to 6 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 6 of 6 new partial solutions.
Adding value "harding"
with keys ("ard" "har" "di")
to 6 partial solutions.
Deleting 12 equivalent partial solutions.
Removing 2 dominated solutions.
Returning 4 of 18 new partial solutions.
Adding value "coolidge"
with keys ("li" "oo")
to 4 partial solutions.
Deleting 4 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 4 of 8 new partial solutions.
Adding value "hoover"
with keys ("oo" "ho")
to 4 partial solutions.
Deleting 4 equivalent partial solutions.
Removing 2 dominated solutions.
Returning 2 of 8 new partial solutions.
Adding value "truman"
with keys ("ma" "ru" "tr")
to 2 partial solutions.
Deleting 4 equivalent partial solutions.
Removing 1 dominated solutions.
Returning 1 of 6 new partial solutions.
Adding value "eisenhower"
with keys ("wer" "sen" "ise" "ow" "ho" "nh" "ei")
to 1 partial solutions.
Deleting 6 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 7 new partial solutions.
Adding value "kennedy"
with keys ("ken" "dy" "ed" "nn")
to 1 partial solutions.
Deleting 3 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 4 new partial solutions.
Adding value "johnson"
with keys ("hn" "oh" "j")
to 1 partial solutions.
Deleting 2 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 3 new partial solutions.
Adding value "nixon"
with keys ("xo" "ix" "ni")
to 1 partial solutions.
Deleting 2 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 3 new partial solutions.
Adding value "carter"
with keys ("car" "rt")
to 1 partial solutions.
Deleting 1 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 2 new partial solutions.
Adding value "reagan"
with keys ("ga" "ag" "ea")
to 1 partial solutions.
Deleting 2 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 3 new partial solutions.
Adding value "bush"
with keys ("sh" "us" "bu")
to 1 partial solutions.
Deleting 2 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 3 new partial solutions.
Adding value "clinton"
with keys ("int" "to" "li")
to 1 partial solutions.
Deleting 2 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 3 new partial solutions.
Adding value "obama"
with keys ("ma" "am" "ba" "ob")
to 1 partial solutions.
Deleting 3 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 4 new partial solutions.
;Value 47: (("rt" "ni" "nn" "ho" "ls" "nl" "vel" "ga" "ye" "ra" "li" "rc" "ta" "po" "har" "bu" "oe" "ma" "j" "ad" "sh"))</pre>The <code>cover</code> procedure takes a table that maps values to the keys that cover them. If we can reduce the size of that table without changing the solution, we'll run faster. If there are two entries in the table such that the keys of one are a superset of the keys of the other, we can discard the superset: the smaller of the two entries will be in the solution, and any key that matches the smaller one will automatically match the larger one as well.
Also, if two values have the same set of keys that match them, we need only include one of the values in the table.
<pre>(define (delete-dominated-values v-k-table)
(let ((size-before (length v-k-table)))
(define (dominated-value? entry)
(let ((entry-value (car entry))
(entry-keylist (cdr entry)))
(there-exists? v-k-table
(lambda (other-entry)
(and (not (eq? entry other-entry))
(let ((other-value (car other-entry))
(other-keylist (cdr other-entry)))
(and (superset? entry-keylist other-keylist)
(not (equal? other-keylist entry-keylist)))))))))
(define (equivalent-value-in-answer? answer entry)
(let ((entry-value (car entry))
(entry-keylist (cdr entry)))
(there-exists? answer
(lambda (other-entry)
(let ((other-value (car other-entry))
(other-keylist (cdr other-entry)))
(equal? entry-keylist other-keylist))))))
(define (add-entry answer entry)
(if (or (equivalent-value-in-answer? answer entry)
(dominated-value? entry))
answer
(cons entry answer)))
(let ((answer (fold-left add-entry '() v-k-table)))
(write-string "Removed ") (write (- size-before (length answer)))
(write-string " dominated and equivalent values.")
(newline)
answer)))
(define (superset? bigger smaller)
(for-all? smaller (lambda (s) (member s bigger))))
(define (mini-golf2 winners losers)
(cover1
(delete-dominated-values
(make-dominant-ngram-table winners (delete-losing-superstrings winners losers)))
lowest-scoring))
;;;;;;;;
;; Delete dominated keys from the keylists.
(define (mini-golf3 winners losers)
(cover1
(delete-dominated-keys-and-values
(make-dominant-ngram-table winners (delete-losing-superstrings winners losers))
(lambda (left right)
(or (< (string-length left) (string-length right))
(and (= (string-length left) (string-length right))
(string<? left right)))))
lowest-scoring))
(define (delete-dominated-keys-and-values v-k-table better-key)
(let ((before-size (fold-left * 1 (map length v-k-table))))
(let ((new-table (delete-dominated-values
(delete-dominated-keys v-k-table better-key))))
(let ((after-size (fold-left * 1 (map length new-table))))
(if (= before-size after-size)
v-k-table
(delete-dominated-keys-and-values new-table better-key))))))
(define (delete-dominated-keys v-k-table better-key)
(let ((all-keys (get-all-keys v-k-table)))
(define (lookup-key key)
(cons key
(map car
(keep-matching-items v-k-table
(lambda (v-k-entry)
(member key (cdr v-k-entry)))))))
(let ((k-v-table (map lookup-key all-keys)))
(define (dominated-key? key)
(let ((values (cdr (assoc key k-v-table))))
(there-exists? k-v-table
(lambda (entry)
(let ((entry-key (car entry))
(entry-values (cdr entry)))
(and (superset? entry-values values)
(not (equal? values entry-values))
(or (< (string-length entry-key) (string-length key))
(and (= (string-length entry-key) (string-length key))
(string<? entry-key key)))))))))
(define (equivalent-key-in-answer? answer key)
(let ((values (cdr (assoc key k-v-table))))
(there-exists? answer
(lambda (entry-key)
(let ((entry-values (cdr (lookup-key entry-key))))
(equal? values entry-values))))))
(define (add-keys answer key)
(if (or (dominated-key? key)
(equivalent-key-in-answer? answer key))
answer
(cons key answer)))
(let ((good-keys (fold-left add-keys '() (sort all-keys better-key))))
(write-string "Removed ") (write (- (length all-keys) (length good-keys)))
(write-string " of ") (write (length all-keys)) (write-string " keys.")(newline)
(map (lambda (entry)
(cons (car entry)
(keep-matching-items (cdr entry) (lambda (key) (member key good-keys)))))
v-k-table)))))
(define (get-all-keys v-k-table)
(fold-left (lambda (answer entry)
(fold-left (lambda (answer key)
(lset-adjoin equal? answer key))
answer
(cdr entry)))
'()
v-k-table))</pre>Trimming the table this way helps a lot. We can now compute the dogs vs. cats.
<pre>1 ]=> (mini-golf3 dogs cats)
Removed 294 of 405 keys.
Removed 44 dominated and equivalent values.
Removed 25 of 93 keys.
Removed 15 dominated and equivalent values.
Removed 7 of 62 keys.
Removed 0 dominated and equivalent values.
Removed 0 of 55 keys.
Removed 0 dominated and equivalent values.
Adding value "BORZOIS"
with keys ("OIS" "BOR" "RZ")
to 1 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 3 of 3 new partial solutions.
Adding value "GIANT SCHNAUZERS"
with keys ("SCH" "HN")
to 3 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 6 of 6 new partial solutions.
Adding value "BASENJIS"
with keys ("JI")
to 6 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 6 of 6 new partial solutions.
Adding value "ENGLISH SETTERS"
with keys ("TERS" "ETT")
to 6 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 12 of 12 new partial solutions.
Adding value "JAPANESE CHIN"
with keys ("CHI")
to 12 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 12 of 12 new partial solutions.
Adding value "BOUVIERS DES FLANDRES"
with keys ("S F" "DES" " DE" "IER" "FL" "VI")
to 12 partial solutions.
Deleting 8 equivalent partial solutions.
Removing 8 dominated solutions.
Returning 56 of 72 new partial solutions.
Adding value "PEKINGESE"
with keys ("EKI")
to 56 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 56 of 56 new partial solutions.
Adding value "BELGIAN MALINOIS"
with keys (" MAL" "OIS" "LG")
to 56 partial solutions.
Deleting 96 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 72 of 168 new partial solutions.
Adding value "GERMAN WIREHAIRED POINTERS"
with keys ("TERS" "D P")
to 72 partial solutions.
Deleting 108 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 36 of 144 new partial solutions.
Adding value "CHOW CHOWS"
with keys ("W ")
to 36 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 36 of 36 new partial solutions.
Adding value "SAMOYEDS"
with keys ("DS")
to 36 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 36 of 36 new partial solutions.
Adding value "DOGUES DE BORDEAUX"
with keys ("BOR" " DE" "GU")
to 36 partial solutions.
Deleting 88 equivalent partial solutions.
Removing 2 dominated solutions.
Returning 18 of 108 new partial solutions.
Adding value "DALMATIANS"
with keys ("ANS" "LM")
to 18 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 36 of 36 new partial solutions.
Adding value "LHASA APSOS"
with keys ("LH")
to 36 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 36 of 36 new partial solutions.
Adding value "CANE CORSO"
with keys (" COR" "ORS")
to 36 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 72 of 72 new partial solutions.
Adding value "ALASKAN MALAMUTES"
with keys (" MAL" "TES" "LAS" "KA")
to 72 partial solutions.
Deleting 184 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 104 of 288 new partial solutions.
Adding value "WHIPPETS"
with keys ("IP")
to 104 partial solutions.
Deleting 0 equivalent partial solutions.
;GC #199: took: 0.20 (1%) CPU time, 0.10 (1%) real time; free: 16754359
Removing 0 dominated solutions.
Returning 104 of 104 new partial solutions.
Adding value "SHIBA INU"
with keys ("SHI" " I")
to 104 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 208 of 208 new partial solutions.
Adding value "AKITAS"
with keys ("AK")
to 208 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 208 of 208 new partial solutions.
Adding value "RHODESIAN RIDGEBACKS"
with keys ("DES" "DG" "OD")
to 208 partial solutions.
Deleting 304 equivalent partial solutions.
Removing 144 dominated solutions.
Returning 176 of 624 new partial solutions.
Adding value "BICHONS FRISES"
with keys ("S F" "FR")
to 176 partial solutions.
Deleting 224 equivalent partial solutions.
Removing 16 dominated solutions.
Returning 112 of 352 new partial solutions.
Adding value "PAPILLONS"
with keys ("API")
to 112 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 112 of 112 new partial solutions.
Adding value "COLLIES"
with keys ("IES")
to 112 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 112 of 112 new partial solutions.
Adding value "VIZSLAS"
with keys ("LAS" "IZ" "VI")
to 112 partial solutions.
;GC #200: took: 0.10 (0%) CPU time, 0.10 (1%) real time; free: 16757322
Deleting 272 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 64 of 336 new partial solutions.
Adding value "BRITTANYS"
with keys ("ITT")
to 64 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 64 of 64 new partial solutions.
Adding value "PUGS"
with keys ("GS")
to 64 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 64 of 64 new partial solutions.
Adding value "HAVANESE"
with keys ("HAVANE")
to 64 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 64 of 64 new partial solutions.
Adding value "COCKER SPANIELS"
with keys ("ANI" "LS")
to 64 partial solutions.
Deleting 80 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 48 of 128 new partial solutions.
Adding value "MASTIFFS"
with keys ("FS")
to 48 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 48 of 48 new partial solutions.
Adding value "MALTESE"
with keys ("TES" "LT")
to 48 partial solutions.
Deleting 72 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 24 of 96 new partial solutions.
Adding value "PEMBROKE WELSH CORGIS"
with keys (" COR" "LS")
to 24 partial solutions.
Deleting 32 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 16 of 48 new partial solutions.
Adding value "BOSTON TERRIERS"
with keys ("IER" " T")
to 16 partial solutions.
Deleting 24 equivalent partial solutions.
Removing 4 dominated solutions.
Returning 4 of 32 new partial solutions.
Adding value "POMERANIANS"
with keys ("ANS" "ANI")
to 4 partial solutions.
Deleting 6 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 2 of 8 new partial solutions.
Adding value "GREAT DANES"
with keys ("GR")
to 2 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 2 of 2 new partial solutions.
Adding value "DOBERMAN PINSCHERS"
with keys ("SCH" " PI")
to 2 partial solutions.
Deleting 3 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 4 new partial solutions.
Adding value "SHIH TZU"
with keys ("SHI" " T")
to 1 partial solutions.
Deleting 1 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 2 new partial solutions.
Adding value "ROTTWEILERS"
with keys ("EI")
to 1 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 1 new partial solutions.
Adding value "POODLES"
with keys ("DL" "OD")
to 1 partial solutions.
Deleting 1 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 2 new partial solutions.
Adding value "BOXERS"
with keys ("OX")
to 1 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 1 new partial solutions.
Adding value "BEAGLES"
with keys ("AGL")
to 1 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 1 new partial solutions.
Adding value "LABRADOR RETRIEVERS"
with keys ("VE")
to 1 partial solutions.
Deleting 0 equivalent partial solutions.
Removing 0 dominated solutions.
Returning 1 of 1 new partial solutions.
;Value 50: (("VE" "AGL" "OX" "EI" "GR" " T" "FS" "LS" "HAVANE" "GS" "ITT" "IES" "API" "FR" "OD" "AK" " I" "IP" "TES" "ORS" "LH" "ANS" "GU" "DS" "W " "EKI" "VI" "CHI" "TERS" "JI" "SCH" "OIS"))</pre>We appear to have the substring version of regex golf under control. Can we extend it to actual regular expressions? Of course we can. In the next installment...<br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-62452715224708931192013-10-18T17:58:00.000-07:002013-10-18T17:58:53.542-07:00Unexciting codeSource code control isn't supposed to be interesting or exciting for the user. Blogging about source code control isn't going to be interesting or surprising for the reader, either. I'll spare you the walkthrough. You're old enough to figure it out without me holding your hand. It'll be more interesting if I blog about the problems and bugs we encountered.<br />
<br />
Conman was the configuration manager built on the core ChangeSafe code. The <em>master catalog</em> in conman holds the highest level objects being managed.<pre>(defclass master-catalog ()
;; subsystems and products (PC's) in this repository
((products :initform nil
:version-technique :composite-set
:accessor master-catalog/products)
(subsystems :initform nil
:version-technique :composite-set
:accessor master-catalog/subsystems)
;; All satellite repositories known to this master. We don't allow
;; satellite repository names to change, though the projects they
;; contain may be renamed. **WARNING** BE CAREFUL IF YOU OPERATE
;; in non-latest metaversion views of this list or you might try to
;; create a satellite which already exists. Only update this list
;; using the latest metaversion.
(satellite-repositories :initform nil :version-technique :composite-set)
;; Projects (a.k.a. ChangeSafe "classes") contained in satellite
;; repositories. The descriptors contain the key mapping from a
;; project name to a satellite-repository-name. We could almost
;; make this just a (project-name . satellite-name) mapping, but we
;; need to version project-name, and we also want to cache in the
;; master some information in the satellites so that we don't
;; always have to examine the satellites for often accessed
;; information.
(classes :accessor master-catalog/classes
:initform nil
:version-technique :composite-set)
;; Cset-relationship-tuples is conceptually a list of sublists,
;; where each sublist is a tuple. For every master cid which
;; results in the creation of satellite cids, a tuple is added
;; which enumerates the master cid and the satellite cids which it
;; caused to be created. e.g. '((master.cid.1 satellite-1.cid.1
;; satellite-2.cid.1)) Because we want portable references, blah
;; blah blah, we actually reference DIDS of CHANGE-SET objects
;; rather than the cids. We may instead wish to store CID-OBJECT
;; references. TBD.
;; Right now, this information is maintained only for change
;; transactions which arise from WITH-CM-MASTER-TXN and
;; WITH-CM-SATELLITE-TXN. This is ok, since those are the
;; interesting txns which manipulate satellite databases.
;; Note that because of the high volume of csets we expect to
;; track, we actually represent this information as a vector of
;; vectors to achieve space compaction.
(cset-relationship-tuples :initform (make-instance 'persistent-vector
:initial-element nil
:size 1)
:version-technique :nonversioned)
(cset-rel-tuples-index :initform (make-instance 'persistent-vector
:initial-element -1
:size 1)
:version-technique :nonversioned)
;; BOTH these slots are updated ONLY by vm-txn-note-change-set,
;; except for schema upgrading.
;; The cset-rel-tuples-index slot is a conceptual hash table into the
;; cset-relationship-tuples slot. This is used by
;; master-catalog-lookup-cset-relationship
;; to avoid an extremely costly linear search of cset-relationship-tuples.
;; This is very important for cset_add, cset_remove, and csets_from_file.
;; The idea is that the did-string of the master-cid's did is hashed.
;; Reducing that hash modulo the number of entries in cset-rel-tuples-index,
;; finds a "home" index of cset-rel-tuples-index. Using the sb32 value
;; in that element, we either have a -1 (so the entry is not in the
;; hash table) or we get an index into cset_relationship_tuples.
;; If there is no hash collision, that element of cset_relationship_tuples
;; will contain the desired master-cid did we are looking for. If it
;; isn't the one we want, we have had a hash collision, and we resolve it
;; by linear probing in the next-door (circularly) element of
;; cset-rel-tuples-index.
;; The number of elements of cset-rel-tuples-index is always a prime number,
;; and is also maintained to be more than twice as large as the number of
;; entries in cset-relationship-tuples. That is important, to prevent
;; clustering and slow searching. So when it grows, cset-rel-tuples-index
;; grows by a reasonable factor (about 2) so that it always contains
;; at least half "holes", that is, -1. Further, we want to avoid frequent
;; growth, because growing requires computing every entry in the hash table
;; again. That makes for a big transaction, as every element of the
;; cid-relationship-tuple vector has to be mapped in, and rehashed with
;; the new size of cset-rel-tuples-index.
;; Space considerations: In Jack's db, there are roughly 40,000 elements
;; currently in the cset-relationship-tuples. Suppose we had 100,000
;; elements. In Jack's db, it appears that the tuples are about 2 elements
;; each, average. Suppose it were 9. Then the tuples would take 4*(1+9)=40
;; bytes each, so 40*100,000 = 4Mb total (plus another 400,000 for the
;; cset-relationship-tuples vector itself). This is large, but not likely
;; to be a cause of breakage anytime soon.
;; The cset-name-hashtable maps cset names to csets. While the HP
;; model of ChangeSafe doesn't allow changing the name of a cset,
;; we allow this in general. So this hash table is keyed by cset
;; name, and valued by all csets which EVER bore that name in their
;; versioned name component. The hash value is therefore a list.
;; In the case of system augmented names (by
;; change_create/master_change), there shouldn't be any collisions.
;; We also use this slot to hash unaugmented user names to csets,
;; and those are far more likely to have collisions (one key ->
;; multiple csets). In the case of un-augmented names, this is
;; expected. In the case of augmented names, this is an error.
(cset-name-hashtable :version-technique nil
:initform (make-instance 'persistent-hash-table :size 1023)
:reader master-catalog/cset-name-hashtable)
)
(:documentation "Catalog/hierarchy-root of versioned information maintained in the master repository.")
(:metaclass versioned-standard-class)
(:schema-version 0))</pre>Pretty straightforward, no? No? Let's list the <em>products</em> in the master catalog:<br />
<pre>(defun cmctl/list-products (conman-request)
"cheesy hack to list the products"
(let ((master-repository-name (conman-request/repository-dbpath conman-request))
(reason "list products")
(userid (conman-request/user-name conman-request)))
(call-with-master-catalog-transaction
master-repository-name
userid
:master-metaversion :latest-metaversion
:version :latest-version
:reason reason
:transaction-type :read-only
:receiver (lambda (master-repository master-transaction master-catalog)
(declare (ignore master-repository master-transaction))
(collect 'list
(map-fn 't (lambda (product)
(list (distributed-object-identifier product)
(named-object/name product)
(described-object/description product)))
(master-catalog/scan-products master-catalog)))))))</pre>That isn't very edifying.<br />
<br />
Start from the end:<pre>(master-catalog/scan-products master-catalog)</pre>defined as<pre>(defun master-catalog/scan-products (master-catalog)
(declare (optimizable-series-function))
(versioned-object/scan-composite-versioned-slot master-catalog 'products))</pre>The <code>optimizable-series-function</code> declaration indicates that we are using Richard Waters's <a href="series.sourceforge.net/">series</a> package. This allows us to write functions that can be assembled into an efficient pipeline for iterating over a collection of objects. This code:<pre>(collect 'list
(map-fn 't (lambda (product)
(list (distributed-object-identifier product)
(named-object/name product)
(described-object/description product)))
(master-catalog/scan-products master-catalog)))</pre>takes each product in turn, creates a three element list of the identifier, the project name, and the product description, and finally collects the three-tuples in a list to be returned to the caller. Here is what it looks like macroexpanded:<pre>(COMMON-LISP:LET* ((#:OUT-917 MASTER-CATALOG))
(COMMON-LISP:LET (#:OUT-914)
(SETQ #:OUT-914 'PRODUCTS)
(COMMON-LISP:LET (#:OUT-913 #:OUT-912)
(SETQ #:OUT-913 (SLOT-VALUE-UNVERSIONED #:OUT-917 #:OUT-914))
(SETQ #:OUT-912
(IF *VERSIONED-VALUE-CID-SET-OVERRIDE*
(PROGN
(DEBUG-MESSAGE 4 "Using override cid-set to scan slot ~s"
#:OUT-914)
*VERSIONED-VALUE-CID-SET-OVERRIDE*)
(TRANSACTION/CID-SET *TRANSACTION*)))
(COMMON-LISP:LET (#:OUT-911 #:OUT-910 #:OUT-909)
(MULTIPLE-VALUE-SETQ (#:OUT-911 #:OUT-910 #:OUT-909)
(CVI-GET-ION-VECTOR-AND-INDEX #:OUT-913 #:OUT-912))
(IF #:OUT-911
NIL
(PROGN
(IF (COMMON-LISP:LET ((#:G717-902 #:OUT-910))
(IF #:G717-902
#:G717-902
(THE T (CVI/DEFAULT-ALLOWED #:OUT-913))))
NIL
(PROGN
(SLOT-UNBOUND (CLASS-OF #:OUT-917) #:OUT-917 #:OUT-914)))))
(DEBUG-MESSAGE 5 "Active ion vector for retrieval: ~s" #:OUT-911)
(COMMON-LISP:LET (#:OUT-908)
(SETQ #:OUT-908
(IF #:OUT-911
#:OUT-911
(THE T #())))
(COMMON-LISP:LET (#:ELEMENTS-907
(#:LIMIT-905 (ARRAY-TOTAL-SIZE #:OUT-908))
(#:INDEX-904 -1)
(#:INDEX-903 (- -1 1))
#:ITEMS-915
#:ITEMS-900
(#:LASTCONS-897 (LIST NIL))
#:LST-898)
(DECLARE (TYPE SERIES::VECTOR-INDEX+ #:LIMIT-905)
(TYPE SERIES::-VECTOR-INDEX+ #:INDEX-904)
(TYPE INTEGER #:INDEX-903)
(TYPE CONS #:LASTCONS-897)
(TYPE LIST #:LST-898))
(SETQ #:LST-898 #:LASTCONS-897)
(TAGBODY
#:LL-918
(INCF #:INDEX-904)
(LOCALLY
(DECLARE (TYPE SERIES::VECTOR-INDEX+ #:INDEX-904))
(IF (= #:INDEX-904 #:LIMIT-905)
(GO SERIES::END))
(SETQ #:ELEMENTS-907
(ROW-MAJOR-AREF #:OUT-908
(THE SERIES::VECTOR-INDEX
#:INDEX-904))))
(INCF #:INDEX-903)
(IF (MINUSP #:INDEX-903)
(GO #:LL-918))
(SETQ #:ITEMS-915
((LAMBDA (ION-SOUGHT)
(CVI-INSERTION-RECORD/GET-VALUE-FOR-ION
(SVREF #:OUT-909 ION-SOUGHT) ION-SOUGHT))
#:ELEMENTS-907))
(SETQ #:ITEMS-900
((LAMBDA (PRODUCT)
(LIST (DISTRIBUTED-OBJECT-IDENTIFIER PRODUCT)
(NAMED-OBJECT/NAME PRODUCT)
(DESCRIBED-OBJECT/DESCRIPTION PRODUCT)))
#:ITEMS-915))
(SETQ #:LASTCONS-897
(SETF (CDR #:LASTCONS-897) (CONS #:ITEMS-900 NIL)))
(GO #:LL-918)
SERIES::END)
(CDR #:LST-898)))))))</pre>To be continued...Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-45892419448730589392013-10-13T17:26:00.001-07:002013-10-13T17:26:37.172-07:00Next stepWe build a simple project/branch/version hierarchical abstraction, and we implement it on top of the core layer. <br />
<br />
<ul><li>a <em>project</em> is a collection of branches that represent alternative ways the state evolves. Every project has a main branch.</li>
<li>A <em>branch</em> is a collection of versions that represent the evolution of the branch state over time.</li>
<li>A <em>version</em> is a collection of change-sets with some trappings.<br />
</li>
<li>A <em>change-set</em> is our unit of change.</li>
</ul>When we do a read/write transaction, we'll add a new change set to the repository. Read-only transactions will specify a version for reading the core objects. Or two versions for generating diffs. Or maybe even three versions for a three-way merge.<br />
<br />
Under this development model, developers will sync their workspace with the most chronologically recent version of the main branch. Their new change sets will be visible only to them, unless (until, we hope) they are "promoted" into the development branch. <br />
<br />
We wanted to encourage frequent incremental check-ins. We wanted hook this up to Emacs autosave. Frequent check-ins of much smaller diffs breaks even.<br />
<br />
Once you get to the point where your code passes all the tests, you promote it into the branch so everyone can use it. Every now and then the admins will "fork a relase", do some "cherrypicks" and make a release branch in the project.<br />
<br />
Once you get to the point where your code passes all the tests, you promote it into the branch so everyone can use it. Every now and then the admins will "fork a relase", do some "cherrypicks" and make a release branch in the project.<br />
<br />
The core code does all the heavy lifting, this is window dressing. The style: minimalist. Skin the change model.<br />
<br />
This is turning into the code equivalent of a power-point lecture. You can read it yourself, I'm not going to walk you through it.<br />
<br />
So that's it? Is that all there is? Many source code or change management systems do something more or less similar to this with files and directory trees instead of CLOS objects. Cute hack, but why all the fuss? Hasn't this been done?<br />
<br />
If it seems obvious to you how we'd implement some of the usual source code control operations, good. We don't have to train you.<br />
<br />
I wont insult your intelligence explaining in detail how to do a rollback by removing a change-set from a version. Use SETF, of course.<br />
<br />
I hope nobody notices the 300 lb chicken sitting next to that shady-looking egg in the corner.<br />
<br />
And something for philosopher/implementors to worry about: If I demote the change-set that instantiates an object, where does the object go? Is it possible create a reference to an uninstantiated object? What happens if you try to follow it?<br />
<br />
<br />
Joe Marshallhttps://plus.google.com/113159534857760391182noreply@blogger.com0