· 9 years ago · Oct 02, 2016, 03:18 PM
1#Ninety-Nine Prospectus Problems
2
3##Working with lists
4
5### 1 Find the last element of a list.
6
7Recur over the elements of the list, and return the last value, wrapped in an Option (which is like a nullable type),
8or else None (which is like null, except that it exists at a type level).
9
10```
11 last [] -> None
12 | [fst] -> Some fst
13 | fst::rst -> last rst
14```
15
16```
17 : last [a, b, c, d]
18 -> d
19```
20
21notes:
22- `[]` is the empty list, and `::` prepends an element to a list
23- `[fst]` is slang for `fst::[]`, the list of only `fst`
24- functions run their clauses in order of declaration, so:
25
26```
27 notLast [] -> None
28 | fst::rst -> last rst
29 | [fst] -> Some fst
30
31 : notLast [1,2,3]
32 ...*infinite loop*...
33```
34
35is broken, and will never terminate/diverge/loop infinitely.
36
37### Find the last but one element of a list.
38
39Similarly recur over the list, but stop before the last element.
40Show off some cool argument-matching.
41
42```
43secondToLast : a, [a] -> Option (a * a)
44secondToLast [] -> None
45 | [fst] -> None
46 | [fst, snd] -> Some (fst, snd)
47 | fst::rest -> secondToLast rest
48
49```
50
51```
52 : secondToLast [a b c d]
53 -> Some (c, d)
54```
55
56notes:
57- for some types a and b, `a * b` is the "product" of those types.
58- products of types are also called tuples, or product types.
59- 'a * b * c' is a product type (for some types a, b, and c). So are `a * a * b`, and `a * a * a * a` etc.
60- an instance of (a * b * c) might be ("string", 111, Some ["list", "of", "strings"])
61- in that case, a = String, b = Integer, and c = Option [String]
62- so (`"string"`, `111`, `Some ["list", "of", "strings"]`) has the type `String * Integer * Option [String]`
63- `[fst]` is equivalent to `fst::[]`
64- `[fst, snd]` is equivalent to `fst::(snd::[])`
65
66Here's a version of `secondToLast` which is a relation instead of a function.
67Functions are mappings from a domain to a range such that for each element of the domain,
68there is one corresponding in the range. As such, they are "deterministic".
69For some function `f`, and some value `a` in f's domain, `f a -> b` any time you call `f a`.
70All functions are relations, but not all relations are functions.
71Relations can map values from the domain to multiple values from the range.
72`r a` can signify any number of values, and we can treat `r a` a lot like a collection type,
73a list, a set, a stream, a whatever.
74We can also check if `r a` has any values at all in the range. Later, we'll use that fact to prove things.
75For now, feel free to think of relations as fancy collections, or indeterminate functions.
76
77Anyway.
78
79```
80 secondToLast [fst, snd] (fst, snd)
81 | fst::rest tuple :- secondToLast rest tuple
82```
83
84```
85 : let rel = secondToLast [a b c d] var
86 : rel.get
87 -> (c, d)
88 : rel.more
89 -> False
90```
91
92Here's an explanation of what we just did:
93- `get` returns the current solution for a relation (relations don't find all of their solutions at call time)
94- `.` switches the order of application. It doesn't access properties. But those are actually pretty similar.
95- `more` searches for more solutions
96
97```
98 : (.) a b = b a
99 : [1,2,3].reverse
100 -> [3,2,1]
101 : let (reverse [1,2,3] r)
102 [1,2,3].reverse == r
103 -> True
104```
105
106So, this is like `let r = reverse[1,2,3]`.
107Calling a relation can introduce a variable to scope, which is strange, but I don't really know a way around it.
108And actually, `=` can be considered a relation which does both assignment and comparison if we really want. But we don't. Today.
109
110### 3 Find the K'th element of a list.
111
112The first element in the list is number 0.
113Empty lists have no 0th element, nor any other.
114Nonempty lists have at least a 0th element, and possibly others.
115Again, we can write this as a relation, but it's very easy to do as a function, so we do.
116
117```
118 elementAt [] k -> None
119 | h::t 0 -> Some h
120 | h::t k -> if (k > 0) then elementAt t k-1 else None # I hate this conditional syntax
121
122 elementAtRel h::t 0 h
123 | h::t k elt :- k > 0, elementAtRel t k-1 elt
124
125 elementAtRel h::t 0 h
126 | h::t k elt :- k > 0, elementAtRel t k-1 elt
127```
128
129note:
130- in a relation body, a comma `(,)` is a synonym for `&&`/`and`
131- there are a couple of trivial advantages here:
132- first, that
133
134```
135 : elementAt [a b c d e] 2
136 -> Some c
137```
138
139### 4 Find the number of elements of a list.
140
141```
142# relation
143length = [] 0
144 | x:xs (1 + length xs)
145
146# function, and explanation
147length lst = fold ((acc, e) -> acc + 1) 0 lst
148
149length lst =
150 # function literals look like: (<space-delimited arguments>) -> <body of function>
151 let stepFunction = (acc e) -> acc + 1
152 # fold takes a function, an optional start value, and a list (in this case),
153 # and returns the result of applying that function to each element of the list and the accumulated start value
154 fold stepFunction 0 lst
155```
156
157```
158 : length [1,2,3]
159 -> 3
160```
161A relation can be coerced into behaving like a function, so this is valid either way, especially for
162relations which only have 1 solution
163(mathematically, such relations are in fact functions, but I don't know how to prove that at the type level reliably)
164but for the relational version, I don't know exactly what happens at the type level.
165the problem is,
166say I want to return from `elementA` at the end of my function `f : [Int] -> Int`,
167and I call the relational version of `elementAt` on an empty list in that function
168the relation can convert that to `[]`, or None, or `-1`, or some other empty-ish value.
169or it can change the type of my program from `[Int] -> Int` and signal a compiler error
170if I try to use f as an `[Int] -> Int` instead of a `? [Int] * Int` (a relation between Int lists and Ints)
171or it can trust me and throw a runtime error if I call it on the empty list.
172
173
174### 5 Reverse a list.
175
176```
177reverse = fwd rev
178 let reverseAux [] lst lst
179 | h::t lst acc :- reverseAux t lst h::acc
180 reverseAux fwd rev []
181```
182
183Reverse: declares an inner-relation (only defined within reverse, keeps the context reverse is called from)
184calls that relation on its arguments (for space efficiency, in this case. if unfamiliar, google "tail call optimization")
185builds up the reversed list, one element at a time (unavoidable in singly-linked lists)
186
187### 6 Find out whether a list is a palindrome.
188
189A palindrome can be read forward or backward; e.g. `[x, a, m, a, x]`.
190
191```
192# isSuccess detects if a relation has any members and returns a bool
193palindromeFn : [_] -> Boolean
194palindromeFn lst -> (reverse lst lst).isSuccess
195
196palindromeRel : ? [_]
197palindromeRel lst :- (reverse lst lst)
198```
199
200### 7 Flatten a nested list structure.
201
202Transform a list, possibly holding lists as elements into a `flat' list,
203by replacing each list with its elements (recursively).
204
205To accomplish this in a type-safe way*, we have to have a type for
206potentially nested lists.
207
208```
209 type Nested a = Flat a | Nest [Nested a]
210```
211
212
213* without having a dependent type-system,
214 which is either an abomination or the best thing ever, depending upon who you ask,
215 but I'm not doing in this language, because it's hard to think about.
216
217```
218flatten : Nested _ -> [_]
219flatten Flat x = [x]
220 | Nest [] = []
221 | Nest (x:xs) = flatten x + flatten (Nest xs)
222
223```
224
225And here's where I'd like some kind of preprocessor, or macro or something.
226`(Nest [ Flat a, Nest [ Flat b, Nest [ Flat c, Flat d ], Flat e ] ])` looks terrible.
227I'd much prever it as `nested [a, [b, [c,d], e]]`
228
229```
230 : flatten (Nest [ Flat a, Nest [ Flat b, Nest [ Flat c, Flat d ], Flat e ] ])
231 -> [a b c d e]
232```
233
234### 8 Eliminate consecutive duplicates of list elements.
235
236If a list contains repeated elements they should be replaced with a
237single copy of the element. The order of the elements should not be
238changed.
239
240```
241compress lst ->
242 let groups = groupBy (e -> e) lst
243 map ((grp, _) -> grp) groups
244```
245
246```
247 : (compress '(a a a a b c c a a d e e e e))
248 -> (a b c a d e)
249```
250
251
252\pagebreak{}
253\subsection*{{P09} (**) Pack consecutive duplicates of
254list elements into sublists.}
255\label{sec:99-problems-P09}
256
257If a list contains repeated elements they should be placed in separate
258sublists.
259
260```
261
262(de consecDups (Lst)
263 (make
264 (let Last NIL
265 (for X Lst
266 (if (= X (car Last))
267 (conc Last (cons X))
268 (link (setq Last (cons X))) ) ) ) ) )
269
270```
271
272```
273 : (consecDups '(a a a a b c c a a d e e e e))
274 -> ((a a a a) (b) (c c) (a a) (d) (e e e e))
275```
276
277\subsection*{{P10} (*) Run-length encoding of a list.}
278\label{sec:99-problems-P10}
279
280Use the result of problem P09 to implement the so-called run-length
281encoding data compression method. Consecutive duplicates of elements are
282encoded as lists (N E) where N is the number of duplicates of the
283element E.
284
285```
286
287(load "p09.l")
288
289(de encode (Lst)
290 (mapcar
291 '((X) (list (length X) (car X)))
292 (consecDups Lst) ) )
293
294```
295
296```
297 : (encode '(a a a a b c c a a d e e e e))
298 -> ((4 a) (1 b) (2 c) (2 a) (1 d)(4 e))
299```
300
301\pagebreak{}
302\subsection*{{P11} (*) Modified run-length encoding.}
303\label{sec:99-problems-P11}
304
305Modify the result of problem P10 in such a way that if an element has no
306duplicates it is simply copied into the result list. Only elements with
307duplicates are transferred as (N E) lists.
308
309```
310
311(load "p09.l")
312
313(de encode-modified (Lst)
314 (mapcar
315 '((X)
316 (if (cdr X)
317 (list (length X) (car X))
318 (car X) ) )
319 (consecDups Lst) ) )
320
321```
322
323```
324 : (encode-modified '(a a a a b c c a a d e e e e))
325 -> ((4 a) b (2 c) (2 a) d (4 e))
326```
327
328\subsection*{{P12} (**) Decode a run-length encoded
329list.}
330\label{sec:99-problems-P12}
331
332Given a run-length code list generated as specified in problem P11.
333Construct its uncompressed version.
334
335```
336
337(de decode (Lst)
338 (make
339 (for X Lst
340 (if (atom X)
341 (link X)
342 (do (car X) (link (cadr X))) ) ) ) )
343
344```
345
346```
347 : (decode '((4 a) b (2 c) (2 a) d (4 e)))
348 -> (a a a a b c c a a d e e e e)
349```
350
351\pagebreak{}
352\subsection*{{P13} (**) Run-length encoding of a list
353(direct solution).}
354\label{sec:99-problems-P13}
355
356Implement the so-called run-length encoding data compression method
357directly. I.e. don't explicitly create the sublists containing the
358duplicates, as in problem P09, but only count them. As in problem P11,
359simplify the result list by replacing the singleton lists (1 X) by X.
360
361```
362
363(de encode-direct (Lst)
364 (make
365 (while Lst
366 (let (N 1 X)
367 (while (= (setq X (pop 'Lst)) (car Lst))
368 (inc 'N) )
369 (link (if (= 1 N) X (list N X))) ) ) ) )
370
371```
372
373```
374 : (encode-direct '(a a a a b c c a a d e e e e))
375 -> ((4 a) b (2 c) (2 a) d (4 e))
376```
377
378\subsection*{{P14} (*) Duplicate the elements of a
379list.}
380\label{sec:99-problems-P14}
381
382```
383
384(de dupli (Lst)
385 (mapcan list Lst Lst) )
386
387```
388
389```
390 : (dupli '(a b c c d))
391 -> (a a b b c c c c d d)
392```
393
394\pagebreak{}
395\subsection*{{P15} (**) Replicate the elements of a list
396a given number of times.}
397\label{sec:99-problems-P15}
398
399```
400
401(de repli (Lst N)
402 (mapcan '((X) (need N NIL X)) Lst) )
403
404```
405
406```
407 : (repli '(a b c) 3)
408 -> (a a a b b b c c c)
409```
410
411
412\subsection*{{P16} (**) Drop every N'th element from a
413list.}
414\label{sec:99-problems-P16}
415
416```
417
418(de drop (Lst N)
419 (make
420 (for (I . X) Lst
421 (unless (=0 (% I N))
422 (link X) ) ) ) )
423
424```
425
426```
427 : (drop '(a b c d e f g h i k) 3)
428 -> (a b d e g h k)
429```
430
431
432\subsection*{{P17} (*) Split a list into two parts; the
433length of the first part is given.}
434\label{sec:99-problems-P17}
435
436Do not use any predefined predicates.
437
438```
439
440(de splitAt (Lst N)
441 (list (cut N 'Lst) Lst) )
442
443```
444
445```
446 : (splitAt '(a b c d e f g h i k) 3)
447 -> ((a b c) (d e f g h i k))
448```
449
450
451\pagebreak{}
452\subsection*{{P18} (**) Extract a slice from a list.}
453\label{sec:99-problems-P18}
454
455Given two indices, I and K, the slice is the list containing the
456elements between the I'th and K'th element of the original list (both
457limits included). Start counting the elements with 1.
458
459```
460
461(de slice (Lst I K)
462 (head (inc (- K I)) (nth Lst I)) )
463
464```
465
466```
467 : (slice '(a b c d e f g h i k) 3 7)
468 -> (c d e f g)
469```
470
471
472\subsection*{{P19} (**) Rotate a list N places to the
473left.}
474\label{sec:99-problems-P19}
475
476```
477
478(de rotate (Lst N)
479 (setq Lst (copy Lst))
480 (do
481 (if (lt0 N)
482 (- N)
483 (- (length Lst) N) )
484 (rot Lst) ) )
485
486```
487
488```
489 : (rotate '(a b c d e f g h) 3)
490 -> (d e f g h a b c)
491
492 : (rotate '(a b c d e f g h) -2)
493 -> (g h a b c d e f)
494```
495
496Hint: Use the predefined functions length and append, as well as the
497result of problem P17.
498
499
500\pagebreak{}
501\subsection*{{P20} (*) Remove the K'th element from a
502list.}
503\label{sec:99-problems-P20}
504
505```
506
507(de remove-at (Lst N)
508 (remove N Lst) )
509
510```
511
512```
513 : (remove-at '(a b c d) 2)
514 -> (a c d)
515```
516
517\subsection*{{P21} (*) Insert an element at a given
518position into a list.}
519\label{sec:99-problems-P21}
520
521```
522
523(de insert-at (X Lst N)
524 (insert N Lst X) )
525
526```
527
528```
529 : (insert-at 'alfa '(a b c d) 2)
530 -> (a alfa b c d)
531```
532
533\subsection*{{P22} (*) Create a list containing all
534integers within a given range.}
535\label{sec:99-problems-P22}
536
537If first argument is smaller than second, produce a list in decreasing
538order.
539
540```
541
542# 'range' is built-in
543# A simplified implementation might be
544
545(de my-range (A B)
546 (let S (if (> B A) 1 -1)
547 (make
548 (until (= A B)
549 (link A)
550 (inc 'A S) ) ) ) )
551
552```
553
554```
555 : (range 4 9)
556 -> (4 5 6 7 8 9)
557```
558
559
560\pagebreak{}
561\subsection*{{P23} (**) Extract a given number of
562randomly selected elements from a list.}
563\label{sec:99-problems-P23}
564
565The selected items shall be returned in a list.
566
567```
568
569(de rnd-select (Lst N)
570 (make
571 (until (=0 N)
572 (when (>= N (rand 1 (length Lst)))
573 (link (car Lst))
574 (dec 'N) )
575 (pop 'Lst) ) ) )
576
577```
578
579```
580 : (rnd-select '(a b c d e f g h) 3)
581 -> (e d a)
582```
583
584Hint: Use the built-in random number generator and the result of problem
585P20.
586
587\subsection*{{P24} (*) Lotto: Draw N different random
588numbers from the set 1..M.}
589\label{sec:99-problems-P24}
590
591The selected numbers shall be returned in a list.
592
593```
594
595(load "p23.l")
596
597(de lotto-select (Cnt Max)
598 (rnd-select (range 1 Max) Cnt) )
599
600```
601
602```
603 : (lotto-select 6 49)
604 -> (23 1 17 33 21 37)
605```
606
607Hint: Combine the solutions of problems P22 and P23.
608
609\pagebreak{}
610\subsection*{{P25} (*) Generate a random permutation of
611the elements of a list.}
612\label{sec:99-problems-P25}
613
614```
615
616(de rnd-permu (Lst)
617 (by '(NIL (rand)) sort Lst) )
618
619```
620
621```
622 : (rnd-permu '(a b c d e f))
623 -> (b a d c e f)
624```
625
626Hint: Use the solution of problem P23.
627
628
629\subsection*{{P26} (**) Generate the combinations of K
630distinct objects chosen from the N elements of a list}
631\label{sec:99-problems-P26}
632
633In how many ways can a committee of 3 be chosen from a group of 12
634people? We all know that there are C(12,3) = 220 possibilities (C(N,K)
635denotes the well-known binomial coefficients). For pure mathematicians,
636this result may be great. But \emph{we} want to really generate all the
637possibilities in a list.
638
639```
640
641(de combination (N Lst)
642 (cond
643 ((=0 N) '(NIL))
644 ((not Lst))
645 (T
646 (conc
647 (mapcar
648 '((X) (cons (car Lst) X))
649 (combination (dec N) (cdr Lst)) )
650 (combination N (cdr Lst)) ) ) ) )
651
652```
653
654```
655 : (combination 3 '(a b c d e f))
656 -> ((a b c) (a b d) (a b e) ... )
657```
658
659\pagebreak{}
660\subsection*{{P27} (**) Group the elements of a set into
661disjoint subsets.}
662\label{sec:99-problems-P27}
663
664a) In how many ways can a group of 9 people work in 3 disjoint subgroups
665of 2, 3 and 4 persons? Write a function that generates all the
666possibilities and returns them in a list.
667
668```
669 : (group3 '(aldo beat carla david evi flip gary hugo ida))
670 -> (((aldo beat) (carla david evi) (flip gary hugo ida))
671 ... )
672```
673
674b) Generalize the above predicate in a way that we can specify a list of
675group sizes and the predicate will return a list of groups.
676
677```
678 : (subsets '(aldo beat carla david evi flip gary hugo ida) '(2 2 5))
679 -> (((aldo beat) (carla david) (evi flip gary hugo ida))
680 ... )
681```
682
683Note that we do not want permutations of the group members; i.e. ((aldo
684beat) \ldots{}) is the same solution as ((beat aldo) \ldots{}). However,
685we make a difference between ((aldo beat) (carla david) \ldots{}) and
686((carla david) (aldo beat) \ldots{}).
687
688You may find more about this combinatorial problem in a good book on
689discrete mathematics under the term ``multinomial coefficients''.
690
691```
692
693(load "p26.l")
694
695(de subsets (Set Lst)
696 (if (cdr Lst)
697 (mapcan
698 '((C)
699 (mapcar
700 '((S) (cons C S))
701 (subsets (diff Set C) (cdr Lst)) ) )
702 (combination (car Lst) Set) )
703 (cons (cons Set)) ) )
704
705```
706
707\pagebreak{}
708\subsection*{{P28} (**) Sorting a list of lists
709according to length of sublists}
710\label{sec:99-problems-P28}
711
712a) We suppose that a list contains elements that are lists themselves.
713The objective is to sort the elements of this list according to their
714\textbf{length}. E.g. short lists first, longer lists later, or vice
715versa.
716
717```
718 : (lsort '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)))
719 -> ((o) (d e) (d e) (m n) (a b c) (f g h) (i j k l))
720```
721
722b) Again, we suppose that a list contains elements that are lists
723themselves. But this time the objective is to sort the elements of this
724list according to their \textbf{length frequency}; i.e., in the default,
725where sorting is done ascendingly, lists with rare lengths are placed
726first, others with a more frequent length come later.
727
728```
729 : (lfsort '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o)))
730 -> ((i j k l) (o) (a b c) (f g h) (d e) (d e) (m n))
731```
732
733Note that in the above example, the first two lists in the result have
734length 4 and 1, both lengths appear just once. The third and forth list
735have length 3 which appears twice (there are two list of this length).
736And finally, the last three lists have length 2. This is the most
737frequent length.
738
739```
740
741(de lsort (Lst)
742 (by length sort Lst) )
743
744(de lfsort (Lst)
745 (by
746 '((X)
747 (cnt
748 '((L) (= (length L) (length X)))
749 Lst ) )
750 sort Lst ) )
751
752```
753
754
755\pagebreak{}
756\section*{Arithmetic}
757
758\subsection*{{P31} (**) Determine whether a given
759integer number is prime.}
760\label{sec:99-problems-P31}
761
762```
763
764(de is-prime (N)
765 (or
766 (= N 2)
767 (and
768 (> N 1)
769 (bit? 1 N)
770 (for (D 3 T (+ D 2))
771 (T (> D (sqrt N)) T)
772 (T (=0 (% N D)) NIL) ) ) ) )
773
774```
775
776```
777 : (is-prime 7)
778 -> T
779```
780
781\subsection*{{P32} (**) Determine the greatest common
782divisor of two positive integer numbers.}
783\label{sec:99-problems-P32}
784
785Use Euclid's algorithm.
786
787```
788
789(de gcd (A B)
790 (until (=0 B)
791 (let M (% A B)
792 (setq A B B M) ) )
793 (abs A) )
794
795```
796
797```
798 : (gcd 36 63)
799 -> 9
800```
801
802\pagebreak{}
803\subsection*{{P33} (*) Determine whether two positive
804integer numbers are coprime.}
805\label{sec:99-problems-P33}
806
807Two numbers are coprime if their greatest common divisor equals 1.
808
809```
810
811(load "p32.l")
812
813(de coprime (A B)
814 (= 1 (gcd A B)) )
815
816```
817
818```
819 : (coprime 35 64)
820 -> T
821```
822
823
824\subsection*{{P34} (**) Calculate Euler's totient
825function phi(m).}
826\label{sec:99-problems-P34}
827
828Euler's so-called totient function phi(m) is defined as the number of
829positive integers r (1 \<= r \< m) that are coprime to m.
830
831Example: m = 10: r = 1,3,7,9; thus phi(m) = 4. Note the special case:
832phi(1) = 1.
833
834```
835 : (totient-phi 10)
836 -> 4
837```
838
839Find out what the value of phi(m) is if m is a prime number. Euler's
840totient function plays an important role in one of the most widely used
841public key cryptography methods (RSA). In this exercise you should use
842the most primitive method to calculate this function (there are smarter
843ways that we shall discuss later).
844
845```
846
847(load "p33.l")
848
849(de totient-phi (N)
850 (cnt
851 '((R) (coprime R N))
852 (range 1 N) ) )
853
854```
855
856\pagebreak{}
857\subsection*{{P35} (**) Determine the prime factors of a
858given positive integer.}
859\label{sec:99-problems-P35}
860
861Construct a flat list containing the prime factors in ascending order.
862
863```
864
865(de prime-factors (N)
866 (make
867 (let (D 2 L (1 2 2 . (4 2 4 2 4 6 2 6 .)) M (sqrt N))
868 (while (>= M D)
869 (if (=0 (% N D))
870 (setq M (sqrt (setq N (/ N (link D)))))
871 (inc 'D (pop 'L)) ) )
872 (link N) ) ) )
873
874```
875
876```
877 : (prime-factors 315)
878 -> (3 3 5 7)
879```
880
881
882\subsection*{{P36} (**) Determine the prime factors of a
883given positive integer (2).}
884\label{sec:99-problems-P36}
885
886Construct a list containing the prime factors and their multiplicity.
887
888```
889
890(load "p09.l")
891(load "p35.l")
892
893(de prime-factors-mult (N)
894 (mapcar
895 '((X) (list (car X) (length X)))
896 (consecDups (prime-factors N)) ) )
897
898```
899
900```
901 : (prime-factors-mult 315)
902 -> ((3 2) (5 1) (7 1))
903```
904
905Hint: The problem is similar to problem P13.
906
907\pagebreak{}
908\subsection*{{P37} (**) Calculate Euler's totient
909function phi(m) (improved).}
910\label{sec:99-problems-P37}
911
912See problem P34 for the definition of Euler's totient function. If the
913list of the prime factors of a number m is known in the form of problem
914P36 then the function phi(m) can be efficiently calculated as
915follows:
916
917 Let ((p1 m1) (p2 m2) (p3 m3) \ldots{}) be the list of prime
918factors (and their multiplicities) of a given number m. Then phi(m) can
919be calculated with the following formula:
920
921```
922
923(load "p36.l")
924
925(de totient-phi (N)
926 (sum # The spec seems wrong, Euler's function needs '*' instead of '+'
927 '((X) # Better use (apply * (mapcar '((X) ..) (prime-factors-mult N)))
928 (*
929 (dec (car X))
930 (** (car X) (dec (cadr X))) ) )
931 (prime-factors-mult N) ) )
932
933```
934
935```
936 phi(m) = (p1 - 1) * p1 ** (m1 - 1) + (p2 - 1) * p2 ** (m2 - 1) +
937 (p3 - 1) * p3 ** (m3 - 1) + ...
938```
939
940Note that a ** b stands for the b'th power of a.
941
942\subsection*{{P38} (*) Compare the two methods of
943calculating Euler's totient function.}
944\label{sec:99-problems-P38}
945
946Use the solutions of problems P34 and P37 to compare the algorithms.
947Take the number of logical inferences as a measure for efficiency. Try
948to calculate phi(10090) as an example.
949
950```
951
952(load "p34.l")
953(bench (do 100 (totient-phi 10090)))
954
955(undef 'totient-phi)
956
957(load "p37.l")
958(bench (do 100 (totient-phi 10090)))
959
960```
961
962\pagebreak{}
963\subsection*{{P39} (*) A list of prime numbers.}
964\label{sec:99-problems-P39}
965
966Given a range of integers by its lower and upper limit, construct a list
967of all prime numbers in that range.
968
969```
970
971# Sieve of Eratosthenes
972(de primes (A B)
973 (let Sieve (range 1 B)
974 (set Sieve)
975 (for I (cdr Sieve)
976 (when I
977 (for (S (nth Sieve (* I I)) S (nth (cdr S) I))
978 (set S) ) ) )
979 (filter '((N) (>= N A)) Sieve) ) )
980
981```
982
983\subsection*{{P40} (**) Goldbach's conjecture.}
984\label{sec:99-problems-P40}
985
986Goldbach's conjecture says that every positive even number greater than
9872 is the sum of two prime numbers. Example: 28 = 5 + 23. It is one of
988the most famous facts in number theory that has not been proved to be
989correct in the general case. It has been \emph{numerically} confirmed up
990to very large numbers. Write a predicate to find the two prime numbers
991that sum up to a given even integer.
992
993```
994
995(load "p31.l")
996
997(de goldbach (N)
998 (unless (bit? 1 N)
999 (for (X 3 (>= N (* 2 X)) (+ 2 X))
1000 (T (and (is-prime X) (is-prime (- N X)))
1001 (list X (- N X)) ) ) ) )
1002
1003```
1004
1005```
1006 : (goldbach 28)
1007 -> (5 23)
1008```
1009
1010\pagebreak{}
1011\subsection*{{P41} (**) A list of Goldbach
1012compositions.}
1013\label{sec:99-problems-P41}
1014
1015Given a range of integers by its lower and upper limit, print a list of
1016all even numbers and their Goldbach composition.
1017
1018```
1019 : (goldbach-list 9 20)
1020 10 = 3 + 7
1021 12 = 5 + 7
1022 14 = 3 + 11
1023 16 = 3 + 13
1024 18 = 5 + 13
1025 20 = 3 + 17
1026```
1027
1028In most cases, if an even number is written as the sum of two prime
1029numbers, one of them is very small. Very rarely, the primes are both
1030bigger than say 50. Try to find out how many such cases there are in the
1031range 2..3000.
1032
1033 Example (for a print limit of 50):
1034
1035```
1036 : (goldbach-list 1 2000 50)
1037 992 = 73 + 919
1038 1382 = 61 + 1321
1039 1856 = 67 + 1789
1040 1928 = 61 + 1867
1041```
1042
1043```
1044
1045(load "p40.l")
1046
1047(de goldbach-list (N Max Lim)
1048 (while (>= Max N)
1049 (let? G (goldbach N)
1050 (when (>= (car G) Lim)
1051 (prinl N " = " (glue " + " G)) ) )
1052 (inc 'N) ) )
1053
1054NIL
1055
1056: (goldbach-list 9 20)
105710 = 3 + 7
105812 = 5 + 7
105914 = 3 + 11
106016 = 3 + 13
106118 = 5 + 13
106220 = 3 + 17
1063-> 21
1064
1065: (goldbach-list 1 2000 50)
1066992 = 73 + 919
10671382 = 61 + 1321
10681856 = 67 + 1789
10691928 = 61 + 1867
1070-> 2001
1071
1072```
1073
1074\pagebreak{}
1075\section*{Logic and Codes}
1076
1077\subsection*{{P46}(**) Truth tables for logical
1078expressions.}
1079\label{sec:99-problems-P46}
1080
1081Define a function that takes a logical expression (a function of two
1082variables) and prints the truth table.
1083
1084```
1085
1086(de truthTable (Fun)
1087 (for X '(T NIL)
1088 (for Y '(T NIL)
1089 (println X Y (Fun X Y)) ) ) )
1090
1091```
1092
1093```
1094 : (truthTable '((A B) (and A (or A B))))
1095 T T T
1096 T NIL T
1097 NIL T NIL
1098 NIL NIL NIL
1099```
1100
1101\pagebreak{}
1102\section*{Miscellaneous Problems}
1103
1104\subsection*{{P90}(**) Eight queens problem}
1105\label{sec:99-problems-P90}
1106
1107This is a classical problem in computer science. The objective is to
1108place eight queens on a chessboard so that no two queens are attacking
1109each other; i.e., no two queens are in the same row, the same column, or
1110on the same diagonal.
1111
1112 Hint: Represent the positions of the queens as
1113a list of numbers 1..N.
1114
1115 Example: (4 2 7 3 6 8 5 1) means that the
1116queen in the first column is in row 4, the queen in the second column is
1117in row 2, etc. Use the generate-and-test paradigm.
1118
1119```
1120
1121(de queens (N)
1122 (let (R (range 1 N) L (copy R) X L)
1123 (recur (X) # Permute
1124 (if (cdr X)
1125 (do (length X)
1126 (recurse (cdr X))
1127 (rot X) )
1128 (or
1129 (seek # Direct check for duplicates
1130 '((L) (member (car L) (cdr L)))
1131 (mapcar + L R) )
1132 (seek
1133 '((L) (member (car L) (cdr L)))
1134 (mapcar - L R) )
1135 (println L) ) ) ) ) )
1136
1137```
1138
1139\pagebreak{}
1140\subsection*{{P91} (**) Knight's tour}
1141\label{sec:99-problems-P91}
1142
1143Another famous problem is this one: How can a knight jump on an NxN
1144chessboard in such a way that it visits every square exactly once?
1145
1146Hints: Represent the squares by pairs of their coordinates of the form
1147X/Y, where both X and Y are integers between 1 and N. (Note that `/' is
1148just a convenient functor, not division!) Define the relation
1149jump(N,X/Y,U/V) to express the fact that a knight can jump from X/Y to
1150U/V on a NxN chessboard. And finally, represent the solution of our
1151problem as a list of N*N knight positions (the knight's tour).
1152
1153```
1154
1155(load "@lib/simul.l")
1156
1157(grid 8 8)
1158
1159# Generate legal moves for a given position
1160(de moves (Tour)
1161 (extract
1162 '((Jump)
1163 (let? Pos (Jump (car Tour))
1164 (unless (memq Pos Tour)
1165 Pos ) ) )
1166 (quote # (taken from "games/chess.l")
1167 ((This) (: 0 1 1 0 -1 1 0 -1 1)) # South Southwest
1168 ((This) (: 0 1 1 0 -1 1 0 1 1)) # West Southwest
1169 ((This) (: 0 1 1 0 -1 -1 0 1 1)) # West Northwest
1170 ((This) (: 0 1 1 0 -1 -1 0 -1 -1)) # North Northwest
1171 ((This) (: 0 1 -1 0 -1 -1 0 -1 -1)) # North Northeast
1172 ((This) (: 0 1 -1 0 -1 -1 0 1 -1)) # East Northeast
1173 ((This) (: 0 1 -1 0 -1 1 0 1 -1)) # East Southeast
1174 ((This) (: 0 1 -1 0 -1 1 0 -1 1)) ) ) ) # South Southeast
1175
1176# Build a list of moves, using Warnsdorff's algorithm
1177: (let Tour '(b1) # Start at b1
1178 (while
1179 (mini
1180 '((P) (length (moves (cons P Tour))))
1181 (moves Tour) )
1182 (push 'Tour @) )
1183 (flip Tour) )
1184
1185-> (b1 a3 b5 a7 c8 b6 a8 c7 a6 b8 d7 f8 h7 g5 h3 g1 e2 c1 a2 b4 c2
1186 a1 b3 a5 b7 d8 c6 d4 e6 c5 a4 c3 d1 b2 c4 d2 f1 h2 f3 e1 d3 e5 f7
1187 h8 g6 h4 g2 f4 d5 e7 g8 h6 g4 e3 f5 d6 e8 g7 h5 f6 e4 g3 h1 f2)
1188
1189```
1190
1191\pagebreak{}
1192\subsection*{{P92} (***) Von Koch's conjecture}
1193\label{sec:99-problems-P92}
1194
1195% \begin{figure}[H]
1196% \centering
1197% \includegraphics[scale=.2]{graphics/P92_1.png}
1198% \end{figure}
1199
1200Several years ago I met a mathematician who was intrigued by a problem
1201for which he didn't know a solution. His name was Von Koch, and I
1202don't know whether the problem has been solved since.
1203
1204Anyway the puzzle goes like this: Given a tree with N nodes (and hence
1205N-1 edges). Find a way to enumerate the nodes from 1 to N and,
1206accordingly, the edges from 1 to N-1 in such a way, that for each edge
1207K the difference of its node numbers equals to
1208K. The conjecture is that this is always possible.
1209
1210
1211% \begin{figure}[H]
1212% \centering
1213% \includegraphics[scale=.6]{graphics/P92_2.png}
1214% \end{figure}
1215
1216
1217For small trees the problem is easy to solve by hand. However, for
1218larger trees, and 14 is already very large, it is extremely difficult
1219to find a solution. And remember, we don't know for sure whether there
1220is always a solution!
1221
1222Write a predicate that calculates a numbering scheme for a given tree.
1223What is the solution for the larger tree pictured above?
1224
1225```
1226
1227We represent the tree as nested lists in the form
1228
1229# edge: number
1230# node: (number . name)
1231# tree: (edge node [tree ..])
1232
1233For example, the representation of the first example's solution is
1234
1235 (7 (7 . a)
1236 (4 (3 . b)
1237 (3 (6 . c))
1238 (2 (5 . e)
1239 (1 (4 . f)) ) )
1240 (6 (1 . d))
1241 (5 (2 . g)) )
1242
1243The function 'kochConjecture' iterates a tree skeleton like
1244
1245(0 (0 . a)
1246 (0 (0 . b)
1247 (0 (0 . c))
1248 (0 (0 . e)
1249 (0 (0 . f)) ) )
1250 (0 (0 . d))
1251 (0 (0 . g)) ) )
1252
1253to obtain solutions like the one above.
1254
1255```
1256
1257```
1258
1259
1260(de kochConjecture (Tree)
1261 (let
1262 (Cnt # Calculate number of nodes
1263 (recur (Tree)
1264 (if Tree
1265 (inc (sum recurse (cddr Tree)))
1266 0 ) )
1267 Edges (range 1 (dec Cnt)) # List of edge numbers
1268 Nodes (range 1 Cnt) # List of node numbers
1269 L Nodes )
1270 (set Tree Cnt) # Set top edge (just for symmetry)
1271 (unless
1272 (recur (L) # Generate node number permutations
1273 (if (cdr L)
1274 (do (length L)
1275 (NIL (recurse (cdr L)))
1276 (rot L) )
1277 (use Nodes # Try next node number permutation
1278 (recur (Tree)
1279 (set (cadr Tree) (pop 'Nodes))
1280 (mapc recurse (cddr Tree)) ) )
1281 (use Edges # Try to fit edges
1282 (recur (Tree)
1283 (let N (caadr Tree) # Node number
1284 (find
1285 '((X)
1286 (let E (abs (- N (caadr X))) # Calculate edge
1287 (or
1288 (not (member E Edges))
1289 (prog
1290 (del E 'Edges)
1291 (set X E)
1292 (recurse X) ) ) ) )
1293 (cddr Tree) ) ) ) ) ) )
1294 Tree ) ) )
1295
1296```
1297
1298```
1299
1300
1301Test run (using 'pretty' to pretty-print the result):
1302
1303(pretty
1304 (kochConjecture
1305 (0 (0 . a)
1306 (0 (0 . b))
1307 (0 (0 . c)
1308 (0 (0 . d)
1309 (0 (0 . k)) )
1310 (0 (0 . e)
1311 (0 (0 . q)
1312 (0 (0 . m))
1313 (0 (0 . n)
1314 (0 (0 . p)) ) ) )
1315 (0 (0 . f)) )
1316 (0 (0 . g))
1317 (0 (0 . h))
1318 (0 (0 . i)) ) ) )
1319
1320This returns as the first solution
1321
1322(14
1323 (1 . a)
1324 (1 (2 . b))
1325 (13
1326 (14 . c)
1327 (11 (3 . d) (9 (12 . k)))
1328 (3
1329 (11 . e)
1330 (6
1331 (5 . q)
1332 (2 (7 . m))
1333 (5 (10 . n) (4 (6 . p))) ) )
1334 (10 (4 . f)) )
1335 (7 (8 . g))
1336 (8 (9 . h))
1337 (12 (13 . i)) )
1338
1339```
1340
1341\pagebreak{}
1342\subsection*{{P93} (***) An arithmetic puzzle}
1343\label{sec:99-problems-P93}
1344
1345Given a list of integer numbers, find a correct way of inserting
1346arithmetic signs (operators) such that the result is a correct equation.
1347Example: With the list of numbers (2 3 5 7 11) we can form the equations
13482-3+5+7 = 11 or 2 = (3*5+7)/11 (and ten others!).
1349
1350```
1351
1352(de infix (E)
1353 (if (atom E)
1354 E
1355 (list
1356 (infix (cadr E))
1357 (car E)
1358 (infix (caddr E)) ) ) )
1359
1360(de expressions (X)
1361 (if (cdr X)
1362 (mapcan
1363 '((I)
1364 (mapcan
1365 '((A)
1366 (mapcan
1367 '((B)
1368 (mapcar
1369 '((Op) (list Op A B))
1370 '(+ - * /) ) )
1371 (expressions (tail (- I) X)) ) )
1372 (expressions (head I X)) ) )
1373 (range 1 (dec (length X))) )
1374 (list (car X)) ) )
1375
1376```
1377
1378```
1379
1380
1381(de equations (Lst)
1382 (use /
1383 (redef / (A B)
1384 (and (n0 B) (=0 (% A B)) (/ A B)) )
1385 (for (I 1 (> (length Lst) I) (inc I))
1386 (for A (expressions (head I Lst))
1387 (for B (expressions (tail (- I) Lst))
1388 (let? N (eval A)
1389 (when (= N (eval B))
1390 (println (infix A) '= (infix B)) ) ) ) ) ) ) )
1391
1392Test:
1393
1394: (equations (2 3 5 7 11))
13952 = (3 - (5 + (7 - 11)))
13962 = (3 - ((5 + 7) - 11))
13972 = ((3 - 5) - (7 - 11))
13982 = ((3 - (5 + 7)) + 11)
13992 = (((3 - 5) - 7) + 11)
14002 = (((3 * 5) + 7) / 11)
1401(2 * (3 - 5)) = (7 - 11)
1402(2 - (3 - (5 + 7))) = 11
1403(2 - ((3 - 5) - 7)) = 11
1404((2 - 3) + (5 + 7)) = 11
1405((2 - (3 - 5)) + 7) = 11
1406(((2 - 3) + 5) + 7) = 11
1407-> NIL
1408
1409```
1410
1411\pagebreak{}
1412\subsection*{{P95} (**) English number words}
1413\label{sec:99-problems-P95}
1414
1415On financial documents, like cheques, numbers must sometimes be written
1416in full words. Example: 175 must be written as ``one hundred
1417seventy-five''. Write a function `fullWords' to return (non-negative)
1418integer numbers in full words.
1419
1420```
1421
1422(de fullWords (N)
1423 (cond
1424 ((=0 N) "zero")
1425 ((> 14 N)
1426 (get
1427 '("one" "two" "three" "four" "five" "six" "seven" "eight"
1428 "nine" "ten" "eleven" "twelve" "thirteen")
1429 N ) )
1430 ((= 15 N) "fifteen")
1431 ((= 18 N) "eighteen")
1432 ((> 20 N) (pack (fullWords (% N 10)) "teen"))
1433 ((> 100 N)
1434 (pack
1435 (get
1436 '("twen" "thir" "for" "fif" "six" "seven" "eigh" "nine")
1437 (dec (/ N 10)) )
1438 "ty"
1439 (unless (=0 (% N 10))
1440 (pack "-" (fullWords (% N 10))) ) ) )
1441 ((rank N '((100 . "hundred") (1000 . "thousand") (1000000 . "million")))
1442 (pack (fullWords (/ N (car @))) " " (cdr @) " " (fullWords (% N (car @)))) ) ) )
1443
1444```
1445
1446\pagebreak{}
1447\subsection*{{P96} (**) Syntax checker}
1448\label{sec:99-problems-P96}
1449
1450% \begin{figure}[H]
1451% \centering
1452% \includegraphics[scale=.6]{graphics/P96_1.png}
1453% \end{figure}
1454
1455In a certain programming language (Ada) identifiers are defined by the
1456syntax diagram (railroad chart) opposite. Transform the syntax diagram
1457into a system of syntax gndiagrams which do not contain loops; i.e.
1458which are purely recursive. Using these modified diagrams, write a
1459function `identifier' that can check whether or not a given string is
1460a legal identifier.
1461
1462```
1463
1464(de identifier (Str)
1465 (and
1466 (>= "z" (lowc (car (setq Str (chop Str)))) "a")
1467 (not
1468 (find
1469 '((C)
1470 (nor
1471 (= "_" C)
1472 (>= "9" C "0")
1473 (>= "z" (lowc C) "a") ) )
1474 (cdr Str) ) ) ) )
1475
1476```
1477
1478
1479\pagebreak{}
1480\subsection*{{P97} (**) Sudoku}
1481\label{sec:99-problems-P97}
1482
1483Sudoku puzzles go like this:
1484
1485```
1486Problem statement Solution
1487
1488 . . 4 | 8 . . | . 1 7 9 3 4 | 8 2 5 | 6 1 7
1489 | | | |
1490 6 7 . | 9 . . | . . . 6 7 2 | 9 1 4 | 8 5 3
1491 | | | |
1492 5 . 8 | . 3 . | . . 4 5 1 8 | 6 3 7 | 9 2 4
1493 --------+---------+-------- --------+---------+--------
1494 3 . . | 7 4 . | 1 . . 3 2 5 | 7 4 8 | 1 6 9
1495 | | | |
1496 . 6 9 | . . . | 7 8 . 4 6 9 | 1 5 3 | 7 8 2
1497 | | | |
1498 . . 1 | . 6 9 | . . 5 7 8 1 | 2 6 9 | 4 3 5
1499 --------+---------+-------- --------+---------+--------
1500 1 . . | . 8 . | 3 . 6 1 9 7 | 5 8 2 | 3 4 6
1501 | | | |
1502 . . . | . . 6 | . 9 1 8 5 3 | 4 7 6 | 2 9 1
1503 | | | |
1504 2 4 . | . . 1 | 5 . . 2 4 6 | 3 9 1 | 5 7 8
1505```
1506
1507Every spot in the puzzle belongs to a (horizontal) row and a (vertical)
1508column, as well as to one single 3x3 square (which we call ``square''
1509for short). At the beginning, some of the spots carry a single-digit
1510number between 1 and 9. The problem is to fill the missing spots with
1511digits in such a way that every number between 1 and 9 appears exactly
1512once in each row, in each column, and in each square.
1513
1514```
1515
1516(load "@lib/simul.l")
1517
1518### Fields/Board ###
1519# val lst
1520
1521(setq
1522 *Board (grid 9 9)
1523 *Fields (apply append *Board) )
1524
1525# Init values to zero (empty)
1526(for L *Board
1527 (for This L
1528 (=: val 0) ) )
1529
1530# Build lookup lists
1531(for (X . L) *Board
1532 (for (Y . This) L
1533 (=: lst
1534 (make
1535 (let A (* 3 (/ (dec X) 3))
1536 (do 3
1537 (inc 'A)
1538 (let B (* 3 (/ (dec Y) 3))
1539 (do 3
1540 (inc 'B)
1541 (unless (and (= A X) (= B Y))
1542 (link
1543 (prop (get *Board A B) 'val) ) ) ) ) ) )
1544 (for Dir '(`west `east `south `north)
1545 (for (This (Dir This) This (Dir This))
1546 (unless (memq (:: val) (made))
1547 (link (:: val)) ) ) ) ) ) ) )
1548
1549# Cut connections (for display only)
1550(for (X . L) *Board
1551 (for (Y . This) L
1552 (when (member X (3 6))
1553 (con (car (val This))) )
1554 (when (member Y (4 7))
1555 (set (cdr (val This))) ) ) )
1556
1557
1558```
1559
1560```
1561
1562# Display board
1563(de display ()
1564 (disp *Board 0
1565 '((This)
1566 (if (=0 (: val))
1567 " "
1568 (pack " " (: val) " ") ) ) ) )
1569
1570# Initialize board
1571(de main (Lst)
1572 (for (Y . L) Lst
1573 (for (X . N) L
1574 (put *Board X (- 10 Y) 'val N) ) )
1575 (display) )
1576
1577# Find solution
1578(de go ()
1579 (unless
1580 (recur (*Fields)
1581 (with (car *Fields)
1582 (if (=0 (: val))
1583 (loop
1584 (NIL
1585 (or
1586 (assoc (inc (:: val)) (: lst))
1587 (recurse (cdr *Fields)) ) )
1588 (T (= 9 (: val)) (=: val 0)) )
1589 (recurse (cdr *Fields)) ) ) )
1590 (display) ) )
1591
1592
1593```
1594
1595```
1596
1597### Usage ###
1598: (main
1599 (quote
1600 (0 0 4 8 0 0 0 1 7)
1601 (6 7 0 9 0 0 0 0 0)
1602 (5 0 8 0 3 0 0 0 4)
1603 (3 0 0 7 4 0 1 0 0)
1604 (0 6 9 0 0 0 7 8 0)
1605 (0 0 1 0 6 9 0 0 5)
1606 (1 0 0 0 8 0 3 0 6)
1607 (0 0 0 0 0 6 0 9 1)
1608 (2 4 0 0 0 1 5 0 0) ) )
1609 +---+---+---+---+---+---+---+---+---+
1610 9 | 4 | 8 | 1 7 |
1611 + + + + + + + + + +
1612 8 | 6 7 | 9 | |
1613 + + + + + + + + + +
1614 7 | 5 8 | 3 | 4 |
1615 +---+---+---+---+---+---+---+---+---+
1616 6 | 3 | 7 4 | 1 |
1617 + + + + + + + + + +
1618 5 | 6 9 | | 7 8 |
1619 + + + + + + + + + +
1620 4 | 1 | 6 9 | 5 |
1621 +---+---+---+---+---+---+---+---+---+
1622 3 | 1 | 8 | 3 6 |
1623 + + + + + + + + + +
1624 2 | | 6 | 9 1 |
1625 + + + + + + + + + +
1626 1 | 2 4 | 1 | 5 |
1627 +---+---+---+---+---+---+---+---+---+
1628 a b c d e f g h i
1629-> NIL
1630
1631
1632```
1633
1634```
1635
1636
1637: (go)
1638 +---+---+---+---+---+---+---+---+---+
1639 9 | 9 3 4 | 8 2 5 | 6 1 7 |
1640 + + + + + + + + + +
1641 8 | 6 7 2 | 9 1 4 | 8 5 3 |
1642 + + + + + + + + + +
1643 7 | 5 1 8 | 6 3 7 | 9 2 4 |
1644 +---+---+---+---+---+---+---+---+---+
1645 6 | 3 2 5 | 7 4 8 | 1 6 9 |
1646 + + + + + + + + + +
1647 5 | 4 6 9 | 1 5 3 | 7 8 2 |
1648 + + + + + + + + + +
1649 4 | 7 8 1 | 2 6 9 | 4 3 5 |
1650 +---+---+---+---+---+---+---+---+---+
1651 3 | 1 9 7 | 5 8 2 | 3 4 6 |
1652 + + + + + + + + + +
1653 2 | 8 5 3 | 4 7 6 | 2 9 1 |
1654 + + + + + + + + + +
1655 1 | 2 4 6 | 3 9 1 | 5 7 8 |
1656 +---+---+---+---+---+---+---+---+---+
1657 a b c d e f g h i
1658-> NIL
1659
1660```
1661
1662\pagebreak{}
1663\subsection*{{P98} (***) Nonograms}
1664\label{sec:99-problems-P98}
1665
1666Around 1994, a certain kind of puzzles was very popular in England. The
1667``Sunday Telegraph'' newspaper wrote: ``Nonograms are puzzles from Japan
1668and are currently published each week only in The Sunday Telegraph.
1669Simply use your logic and skill to complete the grid and reveal a
1670picture or diagram.'' As a PicoProspectus programmer, you are in a better
1671situation: you can have your computer do the work! Just write a little
1672program ;-).
1673
1674 The puzzle goes like this: Essentially, each row and
1675column of a rectangular bitmap is annotated with the respective lengths
1676of its distinct strings of occupied cells. The person who solves the
1677puzzle must complete the bitmap given only these lengths.
1678
1679```
1680 Problem statement: Solution:
1681
1682 |_|_|_|_|_|_|_|_| 3 |_|X|X|X|_|_|_|_| 3
1683 |_|_|_|_|_|_|_|_| 2 1 |X|X|_|X|_|_|_|_| 2 1
1684 |_|_|_|_|_|_|_|_| 3 2 |_|X|X|X|_|_|X|X| 3 2
1685 |_|_|_|_|_|_|_|_| 2 2 |_|_|X|X|_|_|X|X| 2 2
1686 |_|_|_|_|_|_|_|_| 6 |_|_|X|X|X|X|X|X| 6
1687 |_|_|_|_|_|_|_|_| 1 5 |X|_|X|X|X|X|X|_| 1 5
1688 |_|_|_|_|_|_|_|_| 6 |X|X|X|X|X|X|_|_| 6
1689 |_|_|_|_|_|_|_|_| 1 |_|_|_|_|X|_|_|_| 1
1690 |_|_|_|_|_|_|_|_| 2 |_|_|_|X|X|_|_|_| 2
1691 1 3 1 7 5 3 4 3 1 3 1 7 5 3 4 3
1692 2 1 5 1 2 1 5 1
1693```
1694
1695For the example above, the problem can be stated as the two lists ((3)
1696(2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)) and ((1 2) (3 1) (1 5) (7 1)
1697(5) (3) (4) (3)) which give the ``solid'' lengths of the rows and
1698columns, top-to-bottom and left-to-right, respectively. Published
1699puzzles are larger than this example, e.g. 25 x 20, and apparently
1700always have unique solutions.
1701
1702
1703```
1704
1705(de nonogram (LstX LstY)
1706 (let Lim (** 2 (length LstY))
1707 (_nonogX LstX) ) )
1708
1709(de _nonogX (LstX Res)
1710 (if LstX
1711 (_nonogY LstX Res)
1712 (when
1713 (= LstY
1714 (make
1715 (for (I Lim (gt0 (setq I (>> 1 I))))
1716 (link
1717 (flip
1718 (make
1719 (let C NIL
1720 (for N Res
1721 (if2 (bit? I N) C
1722 (inc 'C)
1723 (one C)
1724 (prog (link C) (off C)) ) )
1725 (and C (link @)) ) ) ) ) ) ) )
1726 (for N (flip Res)
1727 (for (I Lim (gt0 (setq I (>> 1 I))))
1728 (prin "|" (if (bit? I N) "X" "_")) )
1729 (prinl "|") ) ) ) )
1730
1731
1732```
1733
1734```
1735
1736
1737(de _nonogY (LstX Res)
1738 (let (Lst (mapcar '((N) (cons 1 (** 2 N))) (car LstX)) P Lst)
1739 (recur (P)
1740 (ifn P
1741 (let N 0
1742 (for X Lst
1743 (setq N
1744 (+
1745 (* 2 N (car X) (cdr X))
1746 (* (car X) (dec (cdr X))) ) ) )
1747 (when (> Lim N)
1748 (_nonogX (cdr LstX) (cons N Res))
1749 T ) )
1750 (prog1 (recurse (cdr P))
1751 (while
1752 (prog
1753 (set (car P) (* 2 (caar P)))
1754 (recurse (cdr P)) ) )
1755 (set (car P) 1) ) ) ) ) )
1756
1757: (nonogram
1758 '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2))
1759 '((1 2) (3 1) (1 5) (7 1) (5) (3) (4) (3)) )
1760|_|X|X|X|_|_|_|_|
1761|X|X|_|X|_|_|_|_|
1762|_|X|X|X|_|_|X|X|
1763|_|_|X|X|_|_|X|X|
1764|_|_|X|X|X|X|X|X|
1765|X|_|X|X|X|X|X|_|
1766|X|X|X|X|X|X|_|_|
1767|_|_|_|_|X|_|_|_|
1768|_|_|_|X|X|_|_|_|
1769-> T
1770
1771```
1772
1773\pagebreak{}
1774\subsection*{{P99} (***) Crossword puzzle}
1775\label{sec:99-problems-P99}
1776
1777Given an empty (or almost empty) framework of a crossword puzzle and a
1778set of words. The problem is to place the words into the framework.
1779
1780% \begin{figure}[H]
1781% \centering
1782% \includegraphics[scale=.6]{graphics/P99_1.png}
1783% \end{figure}
1784
1785The particular crossword puzzle is specified in a text file which
1786first lists the words (one word per line) in an arbitrary order. Then,
1787after an empty line, the crossword framework is defined. In this
1788framework specification, an empty character location is represented by
1789a dot (.). In order to make the solution easier, character locations
1790can also contain predefined character values. The puzzle opposite is
1791defined in the file \href{!wiki?99p99a}{p99a.dat}, other examples are
1792\href{!wiki?99p99b}{p99b.dat} and \href{!wiki?99p99d}{p99d.dat}. There
1793is also an example of a puzzle (\href{!wiki?99p99c}{p99c.dat}) which
1794does not have a solution.
1795
1796\emph{Words} are strings (character lists) of at least two characters.
1797A horizontal or vertical sequence of character places in the crossword
1798puzzle framework is called a \emph{site}.
1799
1800Our problem is to find a compatible way of placing words onto sites.
1801
1802```
1803
1804(load "@lib/simul.l")
1805
1806(de crossword (File)
1807 (use (Words Data Grid Slots Org)
1808 (in File
1809 (setq
1810 Words (flip (by length sort (make (while (line) (link (trim @))))))
1811 Data (flip (make (while (line) (link (trim @))))) # Read data
1812 Len (apply max (mapcar length Data))
1813 Grid (grid Len (length Data)) ) ) # Create grid
1814 (for Col Grid # Set initial data
1815 (use Data
1816 (for This Col
1817 (let C (pop Data)
1818 (=: char (unless (sp? C) C)) )
1819 (pop 'Data) ) ) )
1820 (setq Slots
1821 (mapcar
1822 '((L) (cons (length (car L)) L))
1823 (by length group
1824 (make
1825 (for Col Grid # Init slots
1826 (for This Col
1827 (when (: char)
1828 (and # Check horizontal slot
1829 (not (; (west This) char))
1830 (; (east This) char)
1831 (; (east (east This)) char)
1832 (link
1833 (make
1834 (for (This This (: char) (east This))
1835 (link This) ) ) ) )
1836 (and # Check vertical slot
1837 (not (; (north This) char))
1838 (; (south This) char)
1839 (; (south (south This)) char)
1840 (link
1841 (make
1842 (for (This This (: char) (south This))
1843 (link This) ) ) ) ) ) ) ) ) ) ) )
1844
1845```
1846
1847```
1848
1849
1850 (recur (Words)
1851 (if Words
1852 (for Slot (cdr (assoc (length (car Words)) Slots))
1853 (unless
1854 (find
1855 '((This C) (nor (= C (: char)) (= "." (: char))))
1856 Slot
1857 (car Words) )
1858 (let Org (mapcar get Slot '(char .))
1859 (mapc put Slot '(char .) (car Words))
1860 (recurse (cdr Words))
1861 (mapc put Slot '(char .) Org) ) ) )
1862 (disp Grid T # Found a solution: Display it
1863 '((This)
1864 (if (: char)
1865 (pack " " @ " ")
1866 "###" ) ) ) ) ) ) )
1867
1868: (crossword "p99a.dat")
1869
1870 +---+---+---+---+---+---+---+---+---+
1871 6 | P | R | O | L | O | G |###|###| E |
1872 +---+---+---+---+---+---+---+---+---+
1873 5 | E |###| N |###|###| N |###|###| M |
1874 +---+---+---+---+---+---+---+---+---+
1875 4 | R |###| L | I | N | U | X |###| A |
1876 +---+---+---+---+---+---+---+---+---+
1877 3 | L |###| I |###| F |###| M | A | C |
1878 +---+---+---+---+---+---+---+---+---+
1879 2 |###|###| N |###| S | Q | L |###| S |
1880 +---+---+---+---+---+---+---+---+---+
1881 1 |###| W | E | B |###|###|###|###|###|
1882 +---+---+---+---+---+---+---+---+---+
1883 a b c d e f g h i
1884
1885```
1886
1887
1888\pagebreak{}
1889 \textbf{Hints:}
1890
1891 (1) The problem is not easy. You will need some time to thoroughly
1892 understand it. So, don't give up too early! And remember that the
1893 objective is a clean solution, not just a quick-and-dirty hack!
1894
1895 (2) Reading the data file is a tricky problem (in Prolog?).
1896
1897 (3) For efficiency reasons it is important, at least for larger
1898 puzzles, to sort the words and the sites in a particular order. For
1899 this part of the problem, the solution of P28 may be very helpful.