├── .gitignore ├── LICENSE ├── README.md └── src ├── 01-28 lists ├── p01-p07.lisp ├── p08-p13.lisp ├── p14-p21.lisp └── p22-p28.lisp ├── 31-41 arithmetic └── p31-p41.lisp ├── 46-50 logic └── p46-p50.lisp ├── 54-69 bintrees ├── p54-p60.lisp ├── p61-p63.lisp ├── p64-p66.lisp └── p67-p69.lisp ├── 70-73 multitrees └── p70-p73.lisp ├── 80-89 graphs ├── p80.lisp ├── p81-p84.lisp └── p85-p89.lisp ├── 90-99 misc ├── p90-p91.lisp ├── p92.lisp ├── p93.lisp ├── p94.lisp ├── p95-p96.lisp ├── p97-p98.lisp └── p99.lisp └── 99-lisp-problems.asd /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Ata Deniz Aydın 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 99-lisp-problems 2 | Solutions for the 99 Lisp problems in Common Lisp. 3 | 4 | The [99 Lisp problems](http://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html) are a series of programming problems for the Lisp family of languages, adapted from a similar series of [99 Prolog problems](http://www.ic.unicamp.br/~meidanis/courses/mc336/2009s2/prolog/problemas/) for Prolog. 5 | 6 | The problems are broadly categorized into the following classes: 7 | 8 | * Lists (p01-p28) 9 | * Arithmetic (p31-p41) 10 | * Logic and Codes (p46-p50) 11 | * Binary Trees (p54A-p69) 12 | * Multiway Trees (p70B-p73) 13 | * Graphs (p80-p89) 14 | * Miscellaneous (p90-p99) 15 | -------------------------------------------------------------------------------- /src/01-28 lists/p01-p07.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Basic list operations 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p01 6 | 7 | (defun my-last (list) 8 | "Find the last box of a list. 9 | Example: 10 | * (my-last '(a b c d)) 11 | (D)" 12 | (when list 13 | (if (cdr list) 14 | (my-last (cdr list)) 15 | list))) 16 | 17 | ;;; p02 18 | 19 | (defun my-but-last (list) 20 | "Find the last but one box of a list. 21 | Example: 22 | * (my-but-last '(a b c d)) 23 | (C D)" 24 | (when (cdr list) 25 | (if (cddr list) 26 | (my-but-last (cdr list))) 27 | list))) 28 | 29 | ;;; p03 30 | 31 | (defun element-at (list k) 32 | "Find the K'th element of a list. 33 | The first element in the list is number 1. 34 | Example: 35 | * (element-at '(a b c d e) 3) 36 | C" 37 | (cond ((= k 1) (car list)) 38 | (list (element-at (cdr list) (1- k))))) 39 | 40 | ;;; p04 41 | 42 | (defun my-length (list) 43 | "Find the number of elements of a list." 44 | (if list 45 | (1+ (my-length (cdr list))) 46 | 0)) 47 | 48 | ;;; p05 49 | 50 | (defun my-reverse (list &optional acc) 51 | "Reverse a list." 52 | (if list 53 | (my-reverse (cdr list) (cons (car list) acc)) 54 | acc)) 55 | 56 | ;;; p06 57 | 58 | (defun palindrome-p (list) 59 | "Find out whether a list is a palindrome. 60 | A palindrome can be read forward or backward; e.g. (x a m a x)." 61 | (equal list (my-reverse list))) 62 | 63 | ;;; p07 64 | 65 | (defun my-flatten (list) 66 | "Flatten a nested list structure. 67 | Transform a list, possibly holding lists as elements into a `flat' list by replacing each list with its elements (recursively). 68 | 69 | Example: 70 | * (my-flatten '(a (b (c d) e))) 71 | (A B C D E)" 72 | (cond ((atom list) (list list)) 73 | (list (append (my-flatten (car list)) 74 | (my-flatten (cdr list)))))) 75 | -------------------------------------------------------------------------------- /src/01-28 lists/p08-p13.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Compression, packing, etc. 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p08 6 | 7 | (defun compress (list) 8 | "Eliminate consecutive duplicates of list elements. 9 | If a list contains repeated elements they should be replaced with a single copy of the element. 10 | The order of the elements should not be changed. 11 | 12 | Example: 13 | * (compress '(a a a a b c c a a d e e e e)) 14 | (A B C A D E)" 15 | (if (cdr list) 16 | (if (eq (car list) (cadr list)) 17 | (compress (cdr list)) 18 | (cons (car list) (compress (cdr list)))) 19 | list)) 20 | 21 | ;;; p09 22 | 23 | (defun pack (list) 24 | "Pack consecutive duplicates of list elements into sublists. 25 | If a list contains repeated elements they should be placed in separate sublists. 26 | 27 | Example: 28 | * (pack '(a a a a b c c a a d e e e e)) 29 | ((A A A A) (B) (C C) (A A) (D) (E E E E))" 30 | (if (cdr list) 31 | (let ((res (pack (cdr list)))) 32 | (if (eq (car list) (cadr list)) 33 | (cons (cons (car list) (car res)) (cdr res)) 34 | (cons (list (car list)) res))) 35 | (when list (list list)))) 36 | 37 | ;;; p10 38 | 39 | (defun encode (list) 40 | "Run-length encoding of a list. 41 | Use the result of problem P09 to implement the so-called run-length encoding data compression method. 42 | Consecutive duplicates of elements are encoded as lists (N E) where N is the number of duplicates of the element E. 43 | 44 | Example: 45 | * (encode '(a a a a b c c a a d e e e e)) 46 | ((4 A) (1 B) (2 C) (2 A) (1 D) (4 E))" 47 | (mapcar (lambda (sublist) (list (my-length sublist) ;p04 48 | (car sublist))) 49 | (pack list))) ;p09 50 | 51 | ;;; p11 52 | 53 | (defun encode-modified (list) 54 | "Modified run-length encoding. 55 | Modify the result of problem P10 in such a way that if an element has no duplicates it is simply copied into the result list. 56 | Only elements with duplicates are transferred as (N E) lists. 57 | 58 | Example: 59 | * (encode-modified '(a a a a b c c a a d e e e e)) 60 | ((4 A) B (2 C) (2 A) D (4 E))" 61 | (mapcar (lambda (sublist) 62 | (if (= (car sublist) 1) 63 | (cadr sublist) 64 | sublist)) 65 | (encode list))) ;p11 66 | 67 | ;;; p12 68 | 69 | (defun decode (list) 70 | "Decode a run-length encoded list. 71 | Given a run-length code list generated as specified in problem P11. Construct its uncompressed version." 72 | (my-flatten ;p07 73 | (mapcar (lambda (sublist) 74 | (if (atom sublist) 75 | (list sublist) 76 | (repli (cdr sublist) (car sublist)))) ;p15 77 | (encode-modified list)))) ;p11 78 | 79 | ;;; p13 80 | 81 | (defun encode-direct (list) 82 | "Run-length encoding of a list (direct solution). 83 | Implement the so-called run-length encoding data compression method directly. I.e. don't explicitly create the sublists containing the duplicates, as in problem P09, but only count them. As in problem P11, simplify the result list by replacing the singleton lists (1 X) by X. 84 | 85 | Example: 86 | * (encode-direct '(a a a a b c c a a d e e e e)) 87 | ((4 A) B (2 C) (2 A) D (4 E))" 88 | (if (cdr list) 89 | (let ((res (encode-direct (cdr list)))) 90 | (cond ((and (atom (car res)) 91 | (eq (car list) (car res))) 92 | (cons (list 2 (car list)) (cdr res))) 93 | ((eq (car list) (cadar res)) 94 | (cons (list (1+ (caar res)) (car list)) 95 | (cdr res))))) 96 | list)) 97 | -------------------------------------------------------------------------------- /src/01-28 lists/p14-p21.lisp: -------------------------------------------------------------------------------- 1 | ;;;; More list operations 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p14 6 | 7 | (defun dupli (list) 8 | "Duplicate the elements of a list. 9 | Example: 10 | * (dupli '(a b c c d)) 11 | (A A B B C C C C D D)" 12 | (when list 13 | (cons (car list) 14 | (cons (car list) 15 | (dupli (cdr list)))))) 16 | 17 | ;;; p15 18 | 19 | (defun repli (list n) 20 | "Replicate the elements of a list a given number of times. 21 | Example: 22 | * (repli '(a b c) 3) 23 | (A A A B B B C C C)" 24 | (when list 25 | (add-item (car list) 26 | (repli (cdr list) n) 27 | n))) 28 | 29 | (defun add-item (item list n) 30 | "Add ITEM to LIST N times." 31 | (if (= n 0) 32 | list 33 | (add-item item (cons item list) (1- n)))) 34 | 35 | ;;; p16 36 | 37 | (defun drop (list n &optional (k n)) 38 | "Drop every N'th element from a list. 39 | Example: 40 | * (drop '(a b c d e f g h i k) 3) 41 | (A B D E G H K)" 42 | (when list 43 | (if (= k 1) 44 | (drop (cdr list) n) 45 | (cons (car list) 46 | (drop (cdr list) n (1- k)))))) 47 | 48 | ;;; p17 49 | 50 | (defun split (list n) 51 | "Split a list into two parts; the length of the first part is given. 52 | Do not use any predefined predicates. 53 | 54 | Example: 55 | * (split '(a b c d e f g h i k) 3) 56 | ((A B C) (D E F G H I K))" 57 | (when list 58 | (if (= n 1) 59 | (list (list (car list)) 60 | (cdr list)) 61 | (let ((res (split (cdr list) (1- n)))) 62 | (cons (cons (car list) (car res)) 63 | (cdr res)))))) 64 | 65 | ;;; p18 66 | 67 | (defun slice (list i k) 68 | "Extract a slice from a list. 69 | Given two indices, I and K, the slice is the list containing the elements between the I'th and 70 | K'th element of the original list (both limits included). Start counting the elements with 1. 71 | 72 | Example: 73 | * (slice '(a b c d e f g h i k) 3 7) 74 | (C D E F G)" 75 | (when list 76 | (if (= i 1) 77 | (if (= k 1) 78 | (list (car list)) 79 | (cons (car list) 80 | (slice (cdr list) 1 (1- k)))) 81 | (slice (cdr list) (1- i) (1- k))))) 82 | 83 | ;;; p19 84 | 85 | (defun rotate (list n) 86 | "Rotate a list N places to the left. 87 | Examples: 88 | * (rotate '(a b c d e f g h) 3) 89 | (D E F G H A B C) 90 | 91 | * (rotate '(a b c d e f g h) -2) 92 | (G H A B C D E F)" 93 | (when (< n 0) 94 | (incf n (length list))) 95 | (when list 96 | (let ((partition (split list n))) 97 | (append (cadr partition) (car partition))))) 98 | 99 | ;;; p20 100 | 101 | (defun remove-at (list k) 102 | "Remove the K'th element from a list. 103 | Example: 104 | * (remove-at '(a b c d) 2) 105 | (A C D)" 106 | (if (= k 1) 107 | (cdr list) 108 | (cons (car list) 109 | (remove-at (cdr list) (1- k))))) 110 | 111 | ;;; p21 112 | 113 | (defun insert-at (item list k) 114 | "Insert an element at a given position into a list. 115 | Example: 116 | * (insert-at 'alfa '(a b c d) 2) 117 | (A ALFA B C D)" 118 | (if (= k 1) 119 | (cons item list) 120 | (cons (car list) 121 | (insert-at item (cdr list) (1- k))))) 122 | -------------------------------------------------------------------------------- /src/01-28 lists/p22-p28.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Further index operations 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p22 6 | 7 | (defun range (i k) 8 | "Create a list containing all integers within a given range. 9 | If first argument is smaller than second, produce a list in decreasing order. 10 | Example: 11 | * (range 4 9) 12 | (4 5 6 7 8 9)" 13 | (cond ((= i k) (list i)) 14 | ((< k i) 15 | (reverse (range k i))) 16 | (T 17 | (cons i (range (1+ i) k))))) 18 | 19 | ;;; p23 20 | 21 | (defun rnd-select (list k) 22 | "Extract a given number of randomly selected elements from a list. 23 | The selected items shall be returned in a list. 24 | Example: 25 | * (rnd-select '(a b c d e f g h) 3) 26 | (E D A)" 27 | (when (> k 0) 28 | (let ((i (random (length list)))) 29 | (cons (element-at list i) ;p03 30 | (rnd-select (remove-at list i) ;p20 31 | (1- k)))))) 32 | 33 | ;;; p24 34 | 35 | (defun lotto-select (n m) 36 | "Lotto: Draw N different random numbers from the set 1..M. 37 | The selected numbers shall be returned in a list. 38 | Example: 39 | * (lotto-select 6 49) 40 | (23 1 17 33 21 37)" 41 | (rnd-select (range 1 m) ;p22 42 | n)) ;p23 43 | 44 | ;;; p25 45 | 46 | (defun rnd-permu (list) 47 | "Generate a random permutation of the elements of a list. 48 | Example: 49 | * (rnd-permu '(a b c d e f)) 50 | (B A D C E F)" 51 | (rnd-select list (length list))) ;p23 52 | 53 | ;;; p26 54 | 55 | (defun combination (k list) 56 | "Generate the combinations of K distinct objects chosen from the N elements of a list 57 | In how many ways can a committee of 3 be chosen from a group of 12 people? We all know that there are C(12,3) = 220 possibilities (C(N,K) denotes the well-known binomial coefficients). For pure mathematicians, this result may be great. But we want to really generate all the possibilities in a list. 58 | 59 | Example: 60 | * (combination 3 '(a b c d e f)) 61 | ((A B C) (A B D) (A B E) ... )" 62 | (cond ((null list) NIL) 63 | ((= k 0) (list NIL)) 64 | (T (append (combination k (cdr list)) 65 | (mapcar (lambda (c) (cons (car list) c)) 66 | (combination (1- k) (cdr list))))))) 67 | 68 | 69 | ;;; p27 70 | 71 | (defun group3 (list) 72 | "Group the elements of a set into disjoint subsets. 73 | a) In how many ways can a group of 9 people work in 3 disjoint subgroups of 2, 3 and 4 persons? 74 | Write a function that generates all the possibilities and returns them in a list. 75 | 76 | Example: 77 | * (group3 '(aldo beat carla david evi flip gary hugo ida)) 78 | ( ( (ALDO BEAT) (CARLA DAVID EVI) (FLIP GARY HUGO IDA) ) 79 | ... )" 80 | (group list '(2 3 4))) 81 | 82 | (defun group (list sizes) 83 | "Group the elements of a set into disjoint subsets. 84 | b) Generalize the above predicate in a way that we can specify a list of group sizes 85 | and the predicate will return a list of groups. 86 | 87 | Example: 88 | * (group '(aldo beat carla david evi flip gary hugo ida) '(2 2 5)) 89 | ( ( (ALDO BEAT) (CARLA DAVID) (EVI FLIP GARY HUGO IDA) ) 90 | ... )" 91 | (mapcar (lambda (siz) (partition list siz)) (permutations sizes))) 92 | 93 | (defun partition (list sizes) 94 | "Partition list into sublists of size given in sizes, assuming (apply #'+ sizes) = (length list)." 95 | (if (= (length sizes) 1) 96 | (list list) 97 | (let ((res (split list (car sizes)))) 98 | (list (car res) 99 | (partition res (cdr sizes)))))) 100 | 101 | (defun permutations (list) 102 | "Generate all the different permutations of LIST, accounting for reoccurring terms." 103 | (if list 104 | (mapcar (lambda (item) 105 | (mapcar (lambda (perm) (cons item perm)) 106 | (permutations (remove-item item list)))) 107 | (remove-duplicates list)) 108 | (list NIL))) 109 | 110 | (defun remove-item (item list) 111 | "Remove all instances of ITEM from LIST." 112 | (when list 113 | (if (eq item (car list)) 114 | (remove-item (cdr list)) 115 | (cons (car list) 116 | (remove-item (cdr list)))))) 117 | 118 | (defun remove-duplicates (list) 119 | "Remove all duplicate elements from LIST." 120 | (when list 121 | (cons (car list) 122 | (remove-duplicates 123 | (remove-item (car list) (cdr list)))))) 124 | 125 | ;;; p28 126 | 127 | (defun lsort (list) 128 | "Sorting a list of lists according to length of sublists 129 | a) We suppose that a list contains elements that are lists themselves. 130 | The objective is to sort the elements of this list according to their length. 131 | E.g. short lists first, longer lists later, or vice versa. 132 | 133 | Example: 134 | * (lsort '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o))) 135 | ((O) (D E) (D E) (M N) (A B C) (F G H) (I J K L))" 136 | (sort list (lambda (s1 s2) (< (length s1) (length s2))))) 137 | 138 | (defun lfsort (list) 139 | "b) Again, we suppose that a list contains elements that are lists themselves. 140 | But this time the objective is to sort the elements of this list according to their length frequency; 141 | i.e., in the default, where sorting is done ascendingly, lists with rare lengths are placed first, 142 | others with a more frequent length come later. 143 | 144 | Example: 145 | * (lfsort '((a b c) (d e) (f g h) (d e) (i j k l) (m n) (o))) 146 | ((i j k l) (o) (a b c) (f g h) (d e) (d e) (m n))" 147 | (let ((freqs (mapcar #'reverse (encode (mapcar #'length list))))) ;p10 148 | (sort list (lambda (s1 s2) (< (cadr (assoc (length s1) freqs)) 149 | (cadr (assoc (length s2) freqs))))))) 150 | 151 | (defun sort (list pred) 152 | "Sort list according to the ordering defined by PRED, assumed analogous to <." 153 | (when list 154 | (let ((partition (partition (cdr list) 155 | (lambda (item) (funcall pred item (car list)))))) 156 | (append (sort (car partition) pred) (cons (car list) (sort (cdr partition) pred)))))) 157 | 158 | (defun partition (list pred) 159 | "Separate list into two sublists, the first one containing elements that verify PRED, the second one containing the rest." 160 | (if list 161 | (let ((res (partition (cdr list) pred))) 162 | (if (funcall pred (car list)) 163 | (cons (cons (car list) (car res)) (cdr res)) 164 | (list (car res) (cons (car list) (cadr res))))) 165 | (list NIL NIL))) 166 | -------------------------------------------------------------------------------- /src/31-41 arithmetic/p31-p41.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Prime number arithmetic 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p31 6 | 7 | ;; perhaps adapt this to Eratosthenes' sieve using optional arguments 8 | (defun prime-p (n) 9 | "Determine whether a given integer number is prime. 10 | Example: 11 | * (prime-p 7) 12 | T" 13 | (do ((i 2 (1+ i))) 14 | ((> i (sqrt n)) T) 15 | (when (divides-p i n) 16 | (return-from NIL NIL)))) 17 | 18 | (defun divides-p (d n) 19 | "Return T if D divides N." 20 | (= (rem n i) 0)) 21 | 22 | ;;; p32 23 | 24 | (defun gcd (a b) 25 | "Determine the greatest common divisor of two positive integer numbers. 26 | Use Euclid's algorithm. 27 | Example: 28 | * (gcd 36 63) 29 | 9" 30 | (cond ((< b a) (gcd b a)) 31 | ((= a 0) b) 32 | (T (gcd (rem b a) a)))) 33 | 34 | ;;; p33 35 | 36 | (defun coprime-p (a b) 37 | "Determine whether two positive integer numbers are coprime. 38 | Two numbers are coprime if their greatest common divisor equals 1. 39 | Example: 40 | * (coprime 35 64) 41 | T" 42 | (= (gcd a b) 1)) 43 | 44 | ;;; p34 45 | 46 | (defun totient-phi (n) 47 | "Calculate Euler's totient function phi(m). 48 | Euler's so-called totient function phi(m) is defined as the number of positive integers r (1 <= r < m) that are coprime to m. 49 | Example: m = 10: r = 1,3,7,9; thus phi(m) = 4. Note the special case: phi(1) = 1. 50 | 51 | * (totient-phi 10) 52 | 4" 53 | (do ((d 1 (1+ d)) 54 | (count 0) 55 | ((> d n) count) ;check >, not >=, to account for n = 1; no difference in result for n > 1 56 | (when (coprime-p d n) 57 | (incf count)))) 58 | 59 | ;;; p35 60 | 61 | (defun prime-factors (n) 62 | "Determine the prime factors of a given positive integer. 63 | Construct a flat list containing the prime factors in ascending order. 64 | Example: 65 | * (prime-factors 315) 66 | (3 3 5 7)" 67 | (do ((p 2 (1+ p))) 68 | ((> (* p p) n) (list n)) ;no smaller prime divisor found, n is itself prime 69 | (and (prime-p p) 70 | (divides-p p n) ;prime divisor found 71 | (return-from NIL (cons p (prime-factors (/ n p))))))) 72 | 73 | ;;; p36 74 | 75 | (defun prime-factors-mult (n) 76 | "Determine the prime factors of a given positive integer (2). 77 | Construct a list containing the prime factors and their multiplicity. 78 | Example: 79 | * (prime-factors-mult 315) 80 | ((3 2) (5 1) (7 1))" 81 | (mapcar #'reverse (encode (prime-factors n)))) ;p10 82 | 83 | ;;; p37 84 | 85 | (defun phi-improved (n) 86 | "Calculate Euler's totient function phi(m) (improved). 87 | See problem P34 for the definition of Euler's totient function. If the list of the prime factors of a number m is 88 | known in the form of problem P36 then the function phi(m) can be efficiently calculated as follows: 89 | Let ((p1 m1) (p2 m2) (p3 m3) ...) be the list of prime factors (and their multiplicities) of a given number m. 90 | Then phi(m) can be calculated with the following formula: 91 | phi(m) = (p1 - 1) * p1 ** (m1 - 1) + (p2 - 1) * p2 ** (m2 - 1) + (p3 - 1) * p3 ** (m3 - 1) + ..." 92 | (reduce #'* ;phi is multiplicative 93 | (mapcar (lambda (pair &aux (p (car pair)) (m (cadr pair))) 94 | (* (1- p) (expt p (1- m)))) 95 | (prime-factors-mult n)))) 96 | 97 | ;;; p38 98 | 99 | (defun compare-phi (n) 100 | "Compare the two methods of calculating Euler's totient function. 101 | Use the solutions of problems P34 and P37 to compare the algorithms." 102 | (format t "~%Evaluating phi(~D) using the solution for P34:" n) 103 | (time (totient-phi n)) 104 | (format t "~%Evaluating phi(~D) using the solution for P37:" n) 105 | (time (phi-improved n)) 106 | NIL) 107 | 108 | ;;; p39 109 | 110 | (defun list-primes (a b) 111 | "A list of prime numbers. 112 | Given a range of integers by its lower and upper limit, construct a list of all prime numbers in that range." 113 | (remove-if-not #'prime-p (range a b))) ;p22 114 | 115 | ;;; p40 116 | 117 | (defun goldbach (n) 118 | "Goldbach's conjecture. 119 | Goldbach's conjecture says that every positive even number greater than 2 is the sum of two prime numbers. 120 | Example: 28 = 5 + 23. It is one of the most famous facts in number theory that has not been proved to be correct in the 121 | general case. It has been numerically confirmed up to very large numbers (much larger than we can go with our Lisp system). 122 | Write a predicate to find the two prime numbers that sum up to a given even integer. 123 | Example: 124 | * (goldbach 28) 125 | (5 23)" 126 | (and (evenp n) (> n 2) 127 | (dolist (p (list-primes 2 n)) 128 | (when (prime-p (- n p)) 129 | (return-from NIL (list p (- n p))))))) 130 | 131 | ;;; p41 132 | 133 | (defun goldbach-list (a b &optional (threshold 0)) 134 | "A list of Goldbach compositions. 135 | Given a range of integers by its lower and upper limit, print a list of all even numbers and their Goldbach composition. 136 | Example: 137 | * (goldbach-list 9 20) 138 | 10 = 3 + 7 139 | 12 = 5 + 7 140 | 14 = 3 + 11 141 | 16 = 3 + 13 142 | 18 = 5 + 13 143 | 20 = 3 + 17 144 | 145 | In most cases, if an even number is written as the sum of two prime numbers, one of them is very small. 146 | Very rarely, the primes are both bigger than say 50. Try to find out how many such cases there are in the range 2..3000. 147 | 148 | Example (for a print limit of 50): 149 | * (goldbach-list 1 2000 50) 150 | 992 = 73 + 919 151 | 1382 = 61 + 1321 152 | 1856 = 67 + 1789 153 | 1928 = 61 + 1867" 154 | (mapc (lambda (n &aux (res (goldbach n))) 155 | (when (> (car res) threshold) 156 | (format t "~%~D = ~D + ~D" n (car res) (cadr res)))) 157 | (range a b))) 158 | -------------------------------------------------------------------------------- /src/46-50 logic/p46-p50.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Logic and codes 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p46-48 6 | 7 | ;;; The original Prolog problems rest on language-specific features such as operators. The following functions will concern 8 | ;;; logical expressions formed from predicates, represented as symbols, using operators not, and, or, nand, nor, xor, impl 9 | ;;; and equ. 10 | 11 | (defmacro table (preds expr &optional prefs) 12 | "Print truth table for the given logical expression formed from the given predicates. 13 | Example: 14 | * (table (A B C) (equ (and A (or B C)) (or (and A B) (and A C)))) 15 | true true true true 16 | true true fail true 17 | true fail true true 18 | true fail fail true 19 | fail true true true 20 | fail true fail true 21 | fail fail true true 22 | fail fail fail true" 23 | (if (null preds) 24 | `(format t "~%~{~a~^ ~} ~a" ,(reverse prefs) (bool-symbol ,expr)) 25 | (list 'progn 26 | (table (cdr preds) (subst T (car preds) expr) (cons (bool-symbol T) prefs)) 27 | (table (cdr preds) (subst NIL (car preds) expr) (cons (bool-symbol NIL) prefs))))) 28 | 29 | (defun bool-symbol (bool) 30 | (if bool 'true 'fail)) 31 | 32 | ;; Logical operations 33 | 34 | (defun nand (a b) (not (and a b))) 35 | 36 | (defun nor (a b) (not (or a b))) 37 | 38 | (defun xor (a b) (if a (not b) b)) 39 | 40 | (defun impl (a b) (if a b T)) 41 | 42 | (defun equ (a b) (if a b (not b))) 43 | 44 | ;;; p49 45 | 46 | (let (dict) ;for memoization 47 | (defun gray (n) 48 | "Return the N-bit Gray code, memoized for each N." 49 | (cond ((= n 1) 50 | (list (list 0) (list 1))) ;literal value, no need to memoize 51 | (t 52 | (unless (assoc n dict) ;if not memoized, memoize 53 | (push (list n 54 | (append (mapcar (lambda (code) (cons 0 code)) (gray (1- n))) 55 | (mapcar (lambda (code) (cons 1 code)) (reverse (gray (1- n)))))) 56 | dict)) 57 | (cadr (assoc n dict)))))) 58 | 59 | ;;; p50 60 | 61 | (defun huffman (fs) 62 | "Return the Huffman code table, represented as a list of pairs, given a frequency table also represented as a list of pairs." 63 | (setf fs (copy-tree fs)) ;destructive operations applied to fs 64 | ;; convert fs to binary tree 65 | (do () ((= (length fs) 1)) 66 | ;; sort items based on frequency 67 | (sort fs #'< :key #'cdr) 68 | ;; combine the two least frequent items 69 | (setf fs (cons (cons (cons (caar fs) (caadr fs)) ;collect the items of the first two pairs 70 | (+ (cdar fs) (cdadr fs))) 71 | (cddr fs)))) 72 | (generate-table (caar fs))) 73 | 74 | (defun generate-table (tree) 75 | "Generate Huffman code table from binary tree, represented as a pair containing a tree and a frequency value." 76 | (if (consp tree) ;on a node 77 | (append (mapcar (lambda (pair) (cons (car pair) (cons 0 (cdr pair)))) 78 | (generate-table (car tree))) 79 | (mapcar (lambda (pair) (cons (car pair) (cons 1 (cdr pair)))) 80 | (generate-table (cdr tree)))) 81 | (list (cons tree NIL)))) 82 | -------------------------------------------------------------------------------- /src/54-69 bintrees/p54-p60.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Constructing binary trees 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; In Lisp we represent the empty tree by 'nil' and the non-empty tree by the list (X L R), 6 | ;;; where X denotes the root node and L and R denote the left and right subtree, respectively. 7 | ;;; The example tree depicted opposite is therefore represented by the following list: 8 | ;;; (a (b (d nil nil) (e nil nil)) (c nil (f (g nil nil) nil))) 9 | ;;; Other examples are a binary tree that consists of a root node only: 10 | ;;; (a nil nil) or an empty binary tree: nil. 11 | 12 | ;;; p54 13 | 14 | (defun tree-p (tree) 15 | "Return T if the argument represents a valid binary tree." 16 | (or (null tree) 17 | (and (listp tree) 18 | (= (length tree) 2) 19 | (tree-p (second tree)) 20 | (tree-p (third tree))))) 21 | 22 | ;;; p55 23 | 24 | (defun cbal-trees (n) 25 | "Construct all possible completely balanced trees, i.e. trees for whose every node the difference of the number of nodes 26 | for each subtree is at most 1, with N nodes in total, all containing the symbol X as its value." 27 | (when (> n 0) 28 | (reduce #'union (mapcar #'gen-cbal-trees (cbal-trees (1- n)))))) 29 | 30 | (defun gen-cbal-trees (tree &aux (sym 'X)) 31 | "Generate all completely balanced trees that can be reached by adding a node to the leaves of TREE." 32 | (if (null tree) 33 | (list sym NIL NIL) 34 | (let ((n1 (nodes (second tree))) 35 | (n2 (nodes (third tree)))) 36 | (cond ((= n1 n2) 37 | ;; add nodes to both branches 38 | (union (mapcar (lambda (tr) (list sym (second tree) tr)) 39 | (gen-cbal-trees (third tree))) 40 | (mapcar (lambda (tr) (list sym tr (third tree))) 41 | (gen-cbal-trees (second tree))))) 42 | ((< n1 n2) 43 | ;; only add to left 44 | (mapcar (lambda (tr) (list sym tr (third tree))) 45 | (gen-cbal-trees (second tree)))) 46 | (T 47 | ;; only add to right 48 | (mapcar (lambda (tr) (list sym (second tree) tr)) 49 | (gen-cbal-trees (third tree)))))))) 50 | 51 | (defun cbal-tree-p (tree) 52 | "Return T if TREE is completely balanced." 53 | (or (null tree) 54 | (and (tree-p tree) 55 | (<= (abs (- (nodes (second tree)) 56 | (nodes (third tree)))) 57 | 1) 58 | (cbal-tree-p (second tree)) 59 | (cbal-tree-p (third tree))))) 60 | 61 | (defun nodes (tree) 62 | "Return the number of nodes in TREE." 63 | (if (null tree) 64 | 0 65 | (+ 1 (nodes (second tree)) (nodes (third tree))))) 66 | 67 | ;;; p56 68 | 69 | (defun symmetric-p (tree) 70 | "Return T if the left branch of TREE is the mirror image of the right branch." 71 | (or (null tree) 72 | (mirror-p (second tree) (third tree)))) 73 | 74 | (defun mirror-p (tree1 tree2) 75 | "Return T if TREE1 is the mirror image of TREE2." 76 | (if (null tree1) 77 | (null tree2) 78 | (and (mirror-p (second tree1) (third tree2)) 79 | (mirror-p (third tree1) (second tree2))))) 80 | 81 | ;;; p57 82 | 83 | (defun make-bst (list) 84 | "Construct binary search tree from list of numbers." 85 | (do ((tree NIL (bst-insert (pop list) tree))) 86 | ((null list) tree))) 87 | 88 | (defun bst-insert (item tree) 89 | "Insert item into binary search tree." 90 | (cond ((null tree) (list item NIL NIL)) 91 | ((= item (first tree)) tree) 92 | ((< item (first tree)) 93 | (list (first tree) 94 | (bst-insert item (second tree)) 95 | (third tree))) 96 | (T 97 | (list (first tree) 98 | (second tree) 99 | (bst-insert item (third tree)))))) 100 | 101 | (defun test-symmetric (list) 102 | "Test if the binary search tree constructed from LIST is symmetric." 103 | (symmetric-p (make-bst list))) 104 | 105 | ;;; p58 106 | 107 | (defun sym-cbal-trees (n) 108 | "Generate all symmetric, completely balanced trees with the given number of nodes." 109 | (remove-if-not #'symmetric-p (cbal-trees n))) 110 | 111 | (defun sym-cbal-tree-count (n) 112 | "Return the number of symmetric completely balanced trees with the given number of nodes." 113 | (length (sym-cbal-trees n))) 114 | 115 | ;;; p59 116 | 117 | (defun hbal-tree-p (tree) 118 | "Return T if TREE is height balanced, i.e. for every node the difference of height between subtrees is not greater than 1." 119 | (or (null tree) 120 | (and (tree-p tree) 121 | (<= (abs (- (height (second tree)) 122 | (height (third tree)))) 123 | 1) 124 | (hbal-tree-p (second tree)) 125 | (hbal-tree-p (third tree))))) 126 | 127 | (defun hbal-trees (n) 128 | "Generate all height-balanced trees with the given number of nodes." 129 | (when (> n 0) 130 | (reduce #'union (mapcar #'gen-hbal-trees (hbal-trees (1- n)))))) 131 | 132 | (defun gen-hbal-trees (tree &aux (sym 'X)) 133 | "Generate all height-balanced trees that can be generated by adding a node to a leaf of TREE." 134 | (labels ((gen-right (tree1) 135 | (mapcar (lambda (tr) (list sym (second tree1) tr)) 136 | (gen-hbal-trees (third tree1)))) 137 | (gen-left (tree1) 138 | (mapcar (lambda (tr) (list sym tr (third tree1))) 139 | (gen-hbal-trees (second tree1))))) 140 | (if (null tree) 141 | (list sym NIL NIL) 142 | (let ((h1 (height (second tree))) 143 | (h2 (height (third tree)))) 144 | (cond ((<= (abs (- h1 h2)) 1) 145 | (union (gen-left tree) (gen-right tree))) 146 | ((< h1 h2) 147 | (gen-left tree)) 148 | (T (gen-right tree))))))) 149 | 150 | (defun height (tree) 151 | "Return the height of TREE." 152 | (if (null tree) 153 | 0 154 | (1+ (max (height (second tree)) 155 | (height (third tree)))))) 156 | 157 | ;;; p60 158 | 159 | (defun min-nodes (height) 160 | "Return the minimum number of nodes in a height-balanced tree with given height." 161 | (if (= height 0) 162 | 0 163 | ;; assume one subtree is always shorter than the other 164 | (+ 1 (min-nodes (1- height)) 165 | (min-nodes (- height 2))))) 166 | 167 | (defun max-height (nodes) 168 | "Return the maximum height in a height-balanced tree with the given number of nodes." 169 | (if (= nodes 0) 170 | 0 171 | ;; this is much better suited for Prolog backtracking 172 | (do ((n (ceiling (1- nodes) 2) (1+ n)) 173 | (max 0)) 174 | ((= n nodes) (1+ max)) 175 | (let ((h1 (max-height n)) 176 | (h2 (max-height (- nodes n)))) 177 | (when (<= (abs (- h1 h2)) 1) ;once this is falsified, it shouldn't hold true again 178 | (setf max (max max h1 h2))))))) 179 | 180 | (defun min-height (nodes) 181 | "Return the minimum height in a height-balanced tree with the given number of nodes." 182 | (if (= nodes 0) 183 | 0 184 | ;; assume it is as balanced as possible 185 | (1+ (max (min-height (floor (1- nodes) 2)) 186 | (min-height (ceiling (1- nodes) 2)))))) 187 | 188 | (defun hbal-tree-nodes (nodes) 189 | "Construct all height-balanced trees with the given number of nodes." 190 | (remove-if-not (lambda (tree) 191 | (= (nodes tree) nodes)) 192 | (reduce #'union (mapcar #'hbal-trees (range (min-height nodes) (max-height nodes)))))) 193 | -------------------------------------------------------------------------------- /src/54-69 bintrees/p61-p63.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Collecting leaves, nodes, etc. 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p61 6 | 7 | (defun leaves (tree) 8 | "Collect the leaves, i.e. nodes with no successors, of the given tree." 9 | (and tree (tree-p tree) ;only collect for non-null trees 10 | (if (or (second tree) (third tree)) ;if not a leaf 11 | (append (leaves (second tree)) 12 | (leaves (third tree))) 13 | (list (first tree))))) 14 | 15 | (defun count-leaves (tree) 16 | "Count the leaves of the given tree." 17 | (length (leaves tree))) 18 | 19 | ;;; p62 20 | 21 | (defun internals (tree) 22 | "Collect the internal nodes, nodes with nonempty successors, of the given tree." 23 | (and tree (tree-p tree) 24 | (or (second tree) (third tree)) ;if it contains successors 25 | (cons (first tree) 26 | (append (internals (second tree)) 27 | (internals (third tree)))))) 28 | 29 | ;;; p62b 30 | 31 | (defun nodes-at-level (level tree) 32 | "Collect the nodes at a given level in the tree. 33 | A node of a binary tree is at level N if the path from the root to the node has length N-1. The root node is at level 1." 34 | (if (= level 1) 35 | (list tree) 36 | (append (nodes-at-level (1- level) (second tree)) 37 | (nodes-at-level (1- level) (third tree))))) 38 | 39 | (defun level-order (tree) 40 | "Collect the nodes of TREE ordered by level, using NODES-AT-LEVEL." 41 | (mapcan (lambda (level) (nodes-at-level level tree)) 42 | (range 1 (height tree)))) 43 | 44 | (defun level-order-direct (tree) 45 | "Collect the nodes of TREE ordered by level, using breadth-first search." 46 | (do ((queue (list tree) (cdr queue)) 47 | (acc NIL (cons (caar queue) acc))) ;add item in node 48 | ((null queue) acc) 49 | (nconc queue (remove-if #'null (cdar queue))))) ;only add non-null subtrees to queue 50 | 51 | ;;; p63 52 | 53 | (defun complete-binary-tree (n &optional (address 1) &aux (sym 'X)) 54 | "Construct a complete binary tree. A complete binary tree with height H is defined as follows: 55 | The levels 1,2,3,...,H-1 contain the maximum number of nodes (i.e. 2**(i-1) at the level i, 56 | note that we start counting the levels from 1 at the root). 57 | 58 | We can assign an address number to each node in a complete binary tree by enumerating the nodes in level order, 59 | starting at the root with number 1. In doing so, we realize that for every node X with address A the following property holds: 60 | The address of X's left and right successors are 2*A and 2*A+1, respectively, supposed the successors do exist." 61 | (when (<= address n) 62 | (list sym 63 | (complete-binary-tree n (* 2 address)) 64 | (complete-binary-tree n (1+ (* 2 address)))))) 65 | 66 | (defun complete-binary-tree-p (tree) 67 | "Return T if the given tree is a complete binary tree." 68 | (and (tree-p tree) 69 | ;; every level contains 2^(level - 1) nodes 70 | (every (lambda (level) (= (length (nodes-at-level level tree)) (expt 2 (1- level)))) 71 | (range 1 (1- (height tree)))))) 72 | -------------------------------------------------------------------------------- /src/54-69 bintrees/p64-p66.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Binary tree layout 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; A layout assigns a pair of coordinates to each node, so the node (item left right) is transformed into 6 | ;;; ((item (x . y)) left right). 7 | 8 | ;;; p64 9 | 10 | (defun layout1 (tree &optional (level 1) (left-cousins 0)) 11 | "Lay out binary tree so that the x-coordinate of each node represents its position on the inorder sequence 12 | and the y-coordinate its level." 13 | (when tree 14 | (list (list (first tree) (cons (+ 1 left-cousins (length (nodes (second tree)))) level)) 15 | (layout1 (second tree) (1+ level) left-cousins) 16 | (layout1 (third tree) (1+ level) (+ 1 left-cousins (length (nodes (second tree)))))))) 17 | 18 | ;;; p65 19 | 20 | ;; start-x can be eliminated by laying out the left branch first and adding distance to the x-coord of its root 21 | (defun layout2 (tree &optional (level 1) (distance (expt 2 (- (height tree) 2))) (start-x (start-x tree))) 22 | "Lay out binary tree so that the horizontal distance between each neighbor at a given level is constant." 23 | (when tree 24 | (list (list (first tree) (cons start-x level)) 25 | (layout2 (second tree) (1+ level) (/ distance 2) (- start-x distance)) 26 | (layout2 (third tree) (1+ level) (/ distance 2) (+ start-x distance))))) 27 | 28 | (defun start-x (tree &aux (distance (expt 2 (- (height tree) 2)))) 29 | "The x-coordinate of the root node of tree in layout2." 30 | (if (second tree) 31 | (+ distance (start-x (second tree))) 32 | 0)) 33 | 34 | ;;; p66 35 | 36 | (defun layout3 (tree &optional (level 1)) 37 | "Lay out binary tree so that the horizontal distance between each neighbor at a given level is constant and as small as 38 | possible without two nodes occupying the same position." 39 | (when tree 40 | ;; lay out both the left and the right branch first with their leftmost leaves at x coordinate 0, then shift accordingly 41 | (let* ((left (layout3 (second tree) (1+ level))) 42 | (right (layout3 (third tree) (1+ level))) 43 | (distance (min-distance left right))) 44 | (list (list (first tree) (cons (+ distance (x-coord left)) level)) 45 | left 46 | (shift-right (- (+ (* 2 distance) (x-coord left)) (x-coord right) right))))) 47 | 48 | (defun shift-right (dx tree) 49 | "Shift the x coordinate of each node of tree by dx." 50 | (when tree 51 | (list (list (first (first tree)) (cons (+ dx (x-coord tree)) (y-coord tree))) 52 | (shift-right dx (second tree)) 53 | (shift-right dx (third tree))))) 54 | 55 | (defun min-distance (left right) 56 | "Return the minimum distance between the roots of LEFT and RIGHT, laid out starting from the y axis, 57 | so that the trees don't intersect." 58 | (do ((distance (- (x-coord left) (x-coord (second left))) (1+ distance))) 59 | ((not (intersect-p left right (* 2 distance))) distance))) 60 | 61 | (defun intersect-p (left right dx &aux (rdx (- (+ (x-coord left) dx)) (x-coord right))) 62 | "Return T if a node of LEFT intersects a node of RIGHT when the roots are separated by DX." 63 | (some (lambda (level) 64 | ;; if two points on different trees intersect 65 | (intersection (mapcar #'x-coord (nodes-at-level level left)) 66 | (mapcar (lambda (node) (+ rdx (x-coord node))) 67 | (nodes-at-level level right)))) 68 | (range 1 (1- (min (height left) (height right)))))) 69 | 70 | (defun rightmost (tree) 71 | "Return the x coordinate of the rightmost node in TREE." 72 | (first (sort (mapcar #'x-coord (inorder tree)) #'>))) 73 | 74 | ;;; Auxiliary position functions 75 | 76 | (defun x-coord (tree) 77 | (and tree (tree-p tree) 78 | (car (second (first tree))))) 79 | 80 | (defun y-coord (tree) 81 | (and tree (tree-p tree) 82 | (cdr (second (first tree))))) 83 | -------------------------------------------------------------------------------- /src/54-69 bintrees/p67-p69.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Representations of binary trees 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p67 6 | 7 | (defun tree-to-string (tree) 8 | "Convert the given tree into a string, such that NIL is mapped to \"\", (item NIL NIL) to item, 9 | and (item left right) to item(left,right)." 10 | (if tree 11 | (if (or (second tree) (third tree)) 12 | (format nil "~a(~a,~a)" (first tree) 13 | (tree-to-string (second tree)) 14 | (tree-to-string (third tree))) 15 | (first tree)) 16 | "")) 17 | 18 | ;; not the most efficient parser, but will do 19 | (defun string-to-tree (str) 20 | "Convert the given string into a tree, such that \"\" is mapped to NIL, (item NIL NIL) to item, 21 | and item(left,right) to (item left right)." 22 | (when (> (length str) 0) 23 | (if (char= (char str (1- (length str))) #\)) 24 | (do* ((p1 (position #\( str)) 25 | (depth 0) 26 | (p (1+ p1) (1+ p))) 27 | ((or (null p1) (>= p (length str)))) 28 | (and (= depth 0) 29 | (char= (char str p) #\,) 30 | (return-from NIL 31 | (list (intern (string-upcase (subseq str 0 p1))) 32 | (string-to-tree (subseq str (1+ p1) p)) 33 | (string-to-tree (subseq str (1+ p) (1- (length str))))))) 34 | (case (char str p) 35 | (#\( (incf depth)) 36 | (#\) (decf depth)))) 37 | (list (intern (string-upcase str)) NIL NIL)))) 38 | 39 | ;;; p68 40 | 41 | (defun inorder (tree) 42 | "Construct the inorder sequence of the given tree." 43 | (when tree 44 | (nconc (inorder (second tree)) 45 | (cons (first tree) 46 | (inorder (third tree)))))) 47 | 48 | (defun preorder (tree) 49 | "Construct the preorder sequence of the given tree." 50 | (when tree 51 | (cons (first tree) 52 | (nconc (preorder (second tree)) 53 | (preorder (third tree)))))) 54 | 55 | (defun pre-in-tree (pre in) 56 | "Construct tree from its preorder and inorder representations." 57 | ;; check if pre and in have the same elements 58 | (and pre in 59 | (= (length (union pre in)) 60 | (min (length pre) (length in))) 61 | (let* ((p1 (position (first pre) in)) ;where the left branch ends in in 62 | (p2 (position (first (last (subseq in 0 p1))) pre))) ;where it ends in pre 63 | (list (first pre) 64 | (and p2 (pre-in-tree (subseq pre 1 (1+ p2)) (subseq in 0 p1))) 65 | (and p1 p2 (pre-in-tree (subseq pre (1+ p2)) (subseq in (1+ p1)))))))) 66 | 67 | ;;; p69 68 | 69 | (defun tree-to-dotstring (tree) 70 | "Convert tree to dotstring format, which contains the preorder sequence of the nodes of the tree 71 | with a dot for every instance of NIL encountered. For example, the tree a(b(d,e),c(,f(g,))) as represented in P67 72 | becomes 'abd..e..c.fg...' in dotstring notation." 73 | (if tree 74 | (format nil "~a~a~a" (first tree) 75 | (tree-to-dotstring (second tree)) 76 | (tree-to-dotstring (third tree))) 77 | ".")) 78 | 79 | (defun dotstring-to-tree (str) 80 | "Convert dotstring to tree, where the dotstring contains the preorder sequence of the nodes of the tree 81 | with a dot for every instance of NIL encountered. For example, the tree a(b(d,e),c(,f(g,))) as represented in P67 82 | becomes 'abd..e..c.fg...' in dotstring notation." 83 | ;; treat it like postfix notation in reverse 84 | (do ((i (1- (length str)) (1- i)) 85 | (stack NIL)) 86 | ((< i 0) (pop stack)) 87 | (case (char str i) 88 | (#\. (push NIL stack)) 89 | (T (push (list (intern (make-string 1 :initial-element (char-upcase (char str i)))) 90 | (pop stack) 91 | (pop stack)) 92 | stack))))) 93 | -------------------------------------------------------------------------------- /src/70-73 multitrees/p70-p73.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Multiway tree operations 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; We shall represent a multiway tree as a cons pair containing an atom and a list of subtrees, i.e. as ( *). 6 | ;;; Then binary trees become a subclass of multiway trees with two subtrees at each node. 7 | ;;; However, leaves will have no subtrees, not NIL subtrees. We need not then consider NIL trees. 8 | 9 | ;;; p70 10 | 11 | (defun make-tree (str) 12 | "Construct tree from node string given by the syntax ::= * '^'." 13 | ;; traverse string backwards 14 | (do ((i (1- (length str)) (1- i)) 15 | (stack NIL)) 16 | ((< i 0) (pop stack)) 17 | (case (char str i) 18 | (#\^ 19 | ;; pop until you get a letter 20 | (do* ((item (pop stack) (pop stack)) 21 | (list (cons item NIL) (cons item list))) 22 | ((atom item) (push list stack)))) 23 | (T 24 | ;; add character to stack 25 | (push (intern (make-string 1 :initial-element (char str i))) 26 | stack))))) 27 | 28 | (defun tree-string (tree) 29 | "Convert tree into node string given by the syntax ::= * '^'." 30 | (when (tree-p tree) 31 | (format nil "~a~{~a~^~}^" (car tree) (mapcar #'tree-string (cdr tree))))) 32 | 33 | (defun tree-p (tree) 34 | "Return T if the given s-expression is a valid tree." 35 | (and tree 36 | (listp tree) 37 | (atom (car tree)) 38 | (every #'tree-p (cdr tree))))) 39 | 40 | (defun nnodes (tree) 41 | "Count the nodes of a multiway tree." 42 | (when (tree-p tree) 43 | (1+ (reduce #'+ (mapcar #'nnodes (cdr tree)))))) 44 | 45 | ;;; p71 46 | 47 | (defun ipl (tree) 48 | "Return the internal path length of a tree. The internal path length of a multiway tree 49 | is the total sum of the path lengths from the root to all nodes of the tree." 50 | (when (tree-p tree) 51 | ;; increment every ipl of subtrees, then add the subtrees themselves 52 | (reduce #'+ (mapcar (lambda (tr) (+ 2 (ipl tr))) (cdr tree))))) 53 | 54 | ;;; p72 55 | 56 | (defun bottom-up (tree) 57 | "Sequence the nodes of the given tree bottom up." 58 | (when tree 59 | (nconc (mapcan #'bottom-up (cdr tree)) (list (car tree))))) 60 | 61 | ;;; p73 62 | 63 | ;;; The original problem concerned converting Prolog trees into the lispy format we have been using, so instead 64 | ;;; we will convert Lisp trees into Prolog trees. 65 | ;;; The syntax of a Prolog tree is as follows: 66 | ;;; ::= t(,[{{,}*}]) 67 | 68 | (defun prolog-tree (tree) 69 | "Convert tree into the Prolog tree format, with syntax ::= t(,[{{,}*}])." 70 | (format nil "t(~a,[~{~a~^,~}])" (car tree) (mapcar #'prolog-tree (cdr tree)))) 71 | -------------------------------------------------------------------------------- /src/80-89 graphs/p80.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Graph formats, conversions 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p80 6 | 7 | ;;; We shall consider three formats each for graphs, digraphs and weighted graphs: 8 | ;;; - (default) Graph-term form, containing sets of nodes and edges. 9 | ;;; - Adjacency list form, an association list mapping each node to its neighboring nodes. 10 | ;;; - Human readable form, containing either edges or sole nodes for nodes not connected to any other node. 11 | 12 | ;;; An edge is either a cons pair of nodes, in the case of unweighted edges, or a list of nodes and a weight. 13 | 14 | (defstruct graph 15 | "A graph containing nodes and edges, which might be weighted or unweighted." 16 | nodes edges directed) 17 | 18 | (defun make-ud-graph (nodes edges) 19 | "Make undirected graph with given nodes and edges." 20 | (make-graph :nodes nodes :edges edges :directed NIL)) 21 | 22 | (defun make-d-graph (nodes edges) 23 | "Make directed graph with given nodes and edges." 24 | (make-graph :nodes nodes :edges edges :directed T)) 25 | 26 | (defun adjacency-list (graph) 27 | "Return the adjacency list of a graph." 28 | (mapcar (lambda (node) 29 | (cons node 30 | (mapcar #'cdr 31 | (remove-if-not (lambda (edge) (edge-of edge node graph)) 32 | (graph-edges graph))))) 33 | (graph-nodes graph))) 34 | 35 | (defun readable-list (graph) 36 | "Return a list of edges and lone nodes of a graph." 37 | (append (graph-edges graph) 38 | (lone-nodes graph))) 39 | 40 | (defun lone-nodes (graph) 41 | "Return a list of nodes of a graph not connected to any edge." 42 | (set-difference (graph-nodes graph) 43 | (mapcan #'nodes (graph-edges graph)))) 44 | 45 | (defun ud-adjacency-graph (adj-list &aux (nodes (mapcar #'car adj-list))) 46 | "Make undirected graph from the given adjacency list." 47 | (make-ud-graph 48 | nodes 49 | (let (edges) 50 | (mapc (lambda (n) 51 | (mapc (lambda (x &aux (e (cons n x))) 52 | (unless (member e edges :test (lambda (l1 l2) (null (set-exclusive-or l1 l2))) 53 | :key #'nodes) 54 | (push e edges))) 55 | (cdr (assoc n adj-list)))) 56 | nodes) 57 | edges))) 58 | 59 | (defun d-adjacency-graph (adj-list &aux (nodes (mapcar #'car adj-list))) 60 | "Make directed graph from the given adjacency list." 61 | (make-d-graph 62 | nodes 63 | (let (edges) 64 | (mapc (lambda (n) 65 | (mapc (lambda (x &aux (e (cons n x))) 66 | (push e edges)) 67 | (cdr (assoc n adj-list)))) 68 | nodes) 69 | edges))) 70 | 71 | (defun ud-readable-graph (list &aux (lone-nodes (remove-if-not #'atom list)) (edges (remove-if-not #'edge-p list))) 72 | "Make undirected graph from the given readable list of edges and lone nodes." 73 | (make-ud-graph (append lone-nodes 74 | (mapcan #'nodes edges)) 75 | edges)) 76 | 77 | (defun d-readable-graph (list &aux (lone-nodes (remove-if-not #'atom list)) (edges (remove-if-not #'edge-p list))) 78 | "Make directed graph from the given readable list of edges and lone nodes." 79 | (make-d-graph (append lone-nodes 80 | (mapcan #'nodes edges)) 81 | edges)) 82 | 83 | (defun edge-of (edge node graph) 84 | "Return T if edge starts from node." 85 | (or (eq node (car edge)) 86 | (if (not (graph-directed graph)) ;if undirected, check end 87 | (eq node (end-node edge))))) 88 | 89 | (defun nodes (edge) 90 | "Return the nodes of an edge." 91 | (list (car edge) 92 | (end-node edge))) 93 | 94 | (defun edge-p (edge) 95 | "Return T if the given expression is a valid edge." 96 | (and (consp edge) 97 | (or (atom (cdr edge)) 98 | (atom (cadr edge)) 99 | (null (cdddr edge))))) 100 | 101 | (defun edge (graph node1 node2) 102 | "If there is an edge from NODE1 to NODE2, return T (or the weight of the edge if the graph is weighted)." 103 | (let ((edges (assoc node1 (adjacency-list graph)))) 104 | (if edges 105 | (let ((edge-end (find node2 (cdr edges) 106 | :test (lambda (n e) 107 | (or (eq n e) 108 | (if (consp e) 109 | (eq n (car e)))))))) 110 | (or (atom edge-end) 111 | (cadr edge-end)))))) 112 | 113 | (defun edges (node graph) 114 | "Return all edges in graph that start from node." 115 | (mapcar (lambda (x) (cons node x)) (cdr (assoc node (adjacency-list graph))))) 116 | 117 | (defun neighbors (node graph) 118 | "Return all neighbors of node in graph." 119 | (mapcar (lambda (end) 120 | (if (atom end) 121 | end 122 | (car end))) 123 | (cdr (assoc node (adjacency-list graph))))) 124 | 125 | (defun start-node (edge) 126 | "Return the starting node of an edge." 127 | (car edge)) 128 | 129 | (defun end-node (edge) 130 | "Return the ending node of an edge." 131 | (if (consp (cdr edge)) 132 | (cadr edge) 133 | (cdr edge))) 134 | 135 | (defun other-node (edge node) 136 | "If NODE is a node of EDGE, return the other node of EDGE." 137 | (cond ((eq node (start-node edge)) (end-node edge)) 138 | ((eq node (end-node edge)) (start-node edge)))) 139 | 140 | (defun edge-weight (edge) 141 | "Return the weight of EDGE, if it exists." 142 | (and (edge-p edge) 143 | (consp (cdr edge)) 144 | (caddr edge))) 145 | 146 | (defun empty-p (graph) 147 | (null (graph-nodes graph))) 148 | 149 | (defun subgraph-p (graph1 graph2) 150 | "Return T if GRAPH1 is a subgraph of GRAPH2." 151 | (and (graph-p graph1) 152 | (graph-p graph2) 153 | (subsetp (graph-nodes graph1) (graph-nodes graph2)) 154 | (subsetp (graph-edges graph1) (graph-edges graph2)))) 155 | 156 | (defun graph-equal-p (graph1 graph2) 157 | "Return T if GRAPH1 and GRAPH2 are the same graph." 158 | (null (set-exclusive-or (readable-list graph1) (readable-list graph2) 159 | :test (lambda (a b) 160 | (or (and (not (graph-directed graph1)) 161 | (not (graph-directed graph2)) 162 | (edge-p a) 163 | (edge-p b) 164 | (null (set-exclusive-or (nodes a) (nodes b))) 165 | (eql (edge-weight a) (edge-weight b))) 166 | (eql a b)))))) 167 | -------------------------------------------------------------------------------- /src/80-89 graphs/p81-p84.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Graph paths, spanning trees 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p81 6 | 7 | (defun paths (graph a b) 8 | "Return all acyclic paths from A to B." 9 | (do ((stack (list (list a)) (cdr stack)) ;each element of the stack is an incomplete path in reverse order 10 | res) 11 | ((null stack) res) 12 | (dolist (edge (edges (caar stack) graph)) 13 | (let ((n (other-node edge (caar stack)))) 14 | (unless (member n (cdar stack)) 15 | (if (equal n b) ;end of path 16 | (push (reverse (car stack)) res) 17 | (push (cons n (car stack)) (cdr stack)))))))) 18 | 19 | ;;; p82 20 | 21 | (defun cycles (graph a) 22 | "Return all cycles starting and ending in A." 23 | (mapcan (lambda (edge &aux (n (end-node edge))) 24 | (cons edge (remove (list edge) (paths graph n a) :test #'equal))) 25 | (edges a graph))) 26 | 27 | ;;; p83 28 | 29 | ;; can this be simplified? what can one say about the different trees calculated? 30 | (defun s-trees (graph &aux (len (length (graph-nodes graph)))) 31 | "Generate all spanning trees of GRAPH, where trees are represented as lists of edges." 32 | (do ((stack (list (cons NIL NIL))) ;each element of the stack contains list of visited edges and nodes 33 | res) 34 | ((null stack) res) 35 | (let* ((elem (car stack)) 36 | (edges (car elem)) 37 | (nodes (cdr elem))) 38 | (if (= (length nodes) len) ;complete tree 39 | (pushnew edges res :test-not #'set-exclusive-or) 40 | (dolist (edge (set-difference (graph-edges graph) edges)) ;perhaps include this in elem 41 | (unless (subsetp (nodes edge) nodes) ;the inclusion of edge doesn't form a cycle 42 | (push (cons (cons edge edges) (union (nodes edge) nodes)) (cdr stack)))))))) 43 | 44 | (defun s-tree-p (graph tree) 45 | "Return T if TREE is a spanning tree of GRAPH." 46 | (member tree (s-trees graph))) 47 | 48 | (defun graph-tree-p (graph) 49 | "Return T if GRAPH is a tree." 50 | (s-tree-p graph graph)) 51 | 52 | (defun connected-p (graph) 53 | "Return T if GRAPH is connected." 54 | (not (null (s-trees graph)))) 55 | 56 | ;;; p84 57 | 58 | (defun ms-tree (graph) 59 | "Return minimal spanning tree of GRAPH." 60 | (do ((nodes (graph-nodes graph)) 61 | (costs (mapcar #'list (graph-nodes graph))) ;map nodes to least cost 62 | (edges (mapcar #'list (graph-nodes graph))) ;map nodes to least costly edge 63 | (res (make-graph)) 64 | node) 65 | ((null nodes) res) 66 | (setf node (pred-min nodes #'cost< :key (lambda (n) (assoc n costs)))) ;node with lowest cost 67 | (setf nodes (remove node nodes :test #'equal)) 68 | (push node (graph-nodes res)) 69 | (when (cdr (assoc node edges)) 70 | (push (cdr (assoc node edges)) (graph-edges res))) 71 | (dolist (edge (edges node graph)) 72 | (let ((other (other-node edge node))) 73 | (and (member other nodes) 74 | (cost< (edge-weight edge) (cdr (assoc other costs))) 75 | (rplacd (assoc other costs) (edge-weight edge)) 76 | (rplacd (assoc other edges) edge)))))) 77 | 78 | (defun cost< (cost1 cost2) 79 | "Order costs such that NIL corresponds to positive infinity." 80 | (cond ((null cost1) NIL) ;also includes cost2 being NIL 81 | ((null cost2) T) 82 | (T (< cost1 cost2)))) 83 | 84 | (defun pred-min (list pred &key (key identity)) 85 | "Return minimum of list based on predicate, such that (pred-min list #'<) is (apply #'min list)." 86 | (do ((list (cdr list) (cdr list)) 87 | (min (car list))) 88 | ((null list) min) 89 | (if (funcall pred (funcall key (car list)) 90 | (funcall key min)) 91 | (setf min (car list))))) 92 | -------------------------------------------------------------------------------- /src/80-89 graphs/p85-p89.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Graph isomorphism, traversal, etc. 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p85 6 | 7 | (defun isomorphic-p (graph1 graph2) 8 | "Determine whether the two graphs are isomorphic, and if so, return an isomorphism in the form of an alist." 9 | (and (= (length (graph-nodes graph1)) 10 | (length (graph-nodes graph2))) 11 | (= (length (graph-edges graph1)) 12 | (length (graph-edges graph2))) 13 | (= (length (lone-nodes graph1)) 14 | (length (lone-nodes graph2))) 15 | (append (mapcar #'cons (lone-nodes graph1) (lone-nodes graph2)) 16 | (car (find-isomorphisms graph1 graph2))))) 17 | 18 | (defun find-isomorphisms (graph1 graph2 &optional (edges1 (graph-edges graph1)) (edges2 (graph-edges graph2)) res &aux found) 19 | "Detect isomorphisms between two graphs with the given edges." 20 | (assert (= (length edges1)) (= (length edges2))) 21 | (cond ((null edges1) 22 | res) 23 | ((setf found (find-matches (car edges1) edges2 graph1 graph2 res)) 24 | (mapcan (lambda (match) 25 | (find-isomorphisms graph1 graph2 (cdr edges1) 26 | (remove (car match) edges2) 27 | (append (cdr match) res))) 28 | found)))) 29 | 30 | (defun find-matches (edge edges graph1 graph2 map &aux (start (start-node edge)) (end (end-node edge)) node) 31 | "Return list of possible matches of edge to an element of edges that are compatible with the established vertex mapping." 32 | (cond ((setf node (assoc start map)) 33 | (match-node end node graph1 graph2)) 34 | ((setf node (assoc end map)) 35 | (match-node start node graph1 graph2)) 36 | (T 37 | ;; try mapping edge to each edge in edges whose nodes aren't mapped to any node 38 | (mapcan (lambda (e &aux (start2 (start-node e)) (end2 (end-node e)) matches) 39 | ;; match start-node to start-node or to end-node 40 | (and (= (degree start graph1) 41 | (degree start2 graph2)) 42 | (= (degree end graph1) 43 | (degree end2 graph2)) 44 | (push (list e (cons start start2) (cons end end2)) matches)) 45 | (and (= (degree start graph1) 46 | (degree end2 graph2)) 47 | (= (degree end graph1) 48 | (degree start2 graph2)) 49 | (push (list e (cons start end2) (cons end start2)) matches)) 50 | matches) 51 | (remove-if (lambda (e) (intersection (mapcar #'cdr map) (nodes e))) edges))))) 52 | 53 | (defun match-node (end start graph1 graph2) 54 | "Return list of matches of edge in GRAPH1 ending in END to an edge in GRAPH2 starting with START." 55 | (mapcar (lambda (e) 56 | (list e (cons end (remove start (nodes e))))) 57 | (remove-if-not (lambda (e) 58 | (and (edge-of e start graph2) 59 | (= (degree end graph1) 60 | (degree (remove start (nodes e)) graph2)))) 61 | edges))) 62 | 63 | ;;; p86 64 | 65 | (defun degree (node graph) 66 | "Return the degree of node in graph." 67 | (if (graph-directed graph) 68 | (out-degree node graph) 69 | (+ (out-degree node graph) 70 | (in-degree node graph)))) 71 | 72 | (defun out-degree (node graph) 73 | "Return the out-degree of node in graph." 74 | (length (cdr (assoc node (adjacency-list graph))))) 75 | 76 | (defun in-degree (node graph) 77 | "Return the in-degree of node in graph." 78 | (loop for e in (graph-edges graph) 79 | if (eq node (end-node e)) 80 | sum 1)) 81 | 82 | (defun sorted-nodes (graph) 83 | "Return list of nodes of graph, sorted according to decreasing degree." 84 | (sort (graph-nodes graph) #'> :key (lambda (node) (degree node graph)))) 85 | 86 | (defun color (graph &aux (res (mapcar #'list (graph-nodes graph))) (counter 0)) 87 | "Return alist representing a proper coloring of the nodes of the given graph, colors represented as a positive integer." 88 | (labels ((new-color () (incf counter))) 89 | ;; Welsh-Powell algorithm 90 | (do ((nodes (sorted-nodes graph)) 91 | (node (car nodes) (car nodes)) 92 | (color (new-color) (new-color))) 93 | ((null nodes) res) 94 | ;; color all nodes not connected to node, including node itself, with color 95 | ;; and remove them from the list of sorted nodes 96 | (setf nodes 97 | (remove-if (lambda (n) 98 | (and (not (or (edge node n graph) (edge n node graph))) 99 | (rplacd (assoc n res) color))) 100 | nodes)))) 101 | 102 | ;;; p87 103 | 104 | (defun depth-traverse (graph start) 105 | "Traverse GRAPH depth-first, starting from START." 106 | (do* ((stack (list start) (cdr stack)) 107 | (res stack)) 108 | ((null stack) res) 109 | (dolist (n (neighbors (car stack) graph)) 110 | ;; if not already visited, add n to stack (and thereby res) 111 | (unless (member n res) 112 | (push n (cdr stack)))))) 113 | 114 | ;; returns spanning tree of connected component of start 115 | (defun depth-traverse-edges (graph start) 116 | "Return list of unweighted edges traversed while going through GRAPH depth-first, starting from START." 117 | (do* ((stack (list start) (cdr stack)) 118 | (visited stack) 119 | res 120 | (node (car stack) (car stack))) 121 | ((null stack) (nreverse res)) 122 | (dolist (n (neighbors node graph)) 123 | (unless (member n visited) 124 | (push res (cons node n)) 125 | (push n (cdr stack)))))) 126 | 127 | ;;; p88 128 | 129 | (defun connected-components (graph) 130 | "Return list of connected components of GRAPH." 131 | (do ((nodes (sorted-nodes graph)) ;reach nodes with highest degree first 132 | res) 133 | ((null nodes) res) 134 | (dolist (n (depth-traverse graph (car nodes))) 135 | (setf nodes (remove n nodes)) 136 | (push n res)))) 137 | 138 | ;;; p89 139 | 140 | (defun bipartite-p (graph &aux (colors (mapcar #'list (graph-nodes graph)))) ;initialize for assignment 141 | "If GRAPH is bipartite, return its two parts in a dotted pair; else return NIL." 142 | (labels ((next (color) (- 3 color))) 143 | (dolist (comp (connected-components graph)) 144 | ;; try to color nodes in comp alternating between 1 and 2 145 | (rplacd (assoc (car comp) colors) 1) 146 | (dolist (e (depth-traverse-edges graph (car comp))) 147 | (assert (and (cdr (assoc (start-node e) colors)) ;since comp is traversed depth-first 148 | (not (cdr (assoc (end-node e) colors))))) ;since e is drawn from a tree, (cdr e) must not be already visited 149 | (rplacd (assoc (end-node e) colors) 150 | (next (cdr (assoc (start-node e) colors)))) 151 | ;; look through edges around e 152 | (dolist (edge (edges (end-node e) graph)) 153 | ;; if there is a coloring conflict, return NIL 154 | (if (eq (assoc (start-node edge) colors) 155 | (assoc (end-node edge) colors)) 156 | (return-from 'BIPARTITE-P)))))) 157 | ;; partition nodes based on their coloring 158 | (let ((res (list NIL))) 159 | (dolist (coloring colors res) 160 | (case (cdr coloring) 161 | (1 (push (car coloring) (car res))) 162 | (2 (push (car coloring) (cdr res))) 163 | (T (return-from 'BIPARTITE-P)))))) ;if some node is left uncolored 164 | -------------------------------------------------------------------------------- /src/90-99 misc/p90-p91.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Chessboard problems 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p90 6 | 7 | (defun eight-queens (&optional (n 8)) 8 | "Return solutions for the eight queens problem in the form of N-element lists of numbers from 1 to N, 9 | each representing the row of the queen on each column." 10 | (mapcan (lambda (r) (try-row r n)) (range 1 n))) 11 | 12 | (defun try-row (row &optional (n 8) (col 1) visited) 13 | "Return solutions for the eight queens problem that start with the given row number." 14 | (if (= col n) 15 | (list (list row)) 16 | (mapcan (lambda (r) 17 | (mapcar (lambda (sol) (cons row sol)) 18 | (remove-if (lambda (sol) (incompatible-p row sol)) 19 | (try-row r n (1+ col) (cons row visited))))) 20 | (set-difference (range 1 n) (cons row visited))))) 21 | 22 | (defun incompatible-p (row sol) 23 | "Return T if there is a queen in SOL that is on the same diagonal as ROW (those on the same row are eliminated by TRY-ROW)." 24 | (do ((up (1- row) (1- up)) 25 | (down (1+ row) (1+ down))) 26 | ((null sol)) 27 | (when (member (pop sol) (list up down)) 28 | (return T)))) 29 | 30 | ;;; p91 31 | 32 | (defun knights-tour (&optional (n 8) (m (* n n)) (visited (list (cons 1 1)))) 33 | "Return all possible ways a knight can move on a NxN chessboard such that every square is visited only once." 34 | (if (= m 0) 35 | visited 36 | (mapcan (lambda (next) 37 | (knights-tour n (1- m) (cons next visited))) 38 | (set-difference (next-squares (car visited) n) visited)))) 39 | 40 | (defun next-squares (sq n) 41 | "Return the squares that SQ can move to on an NxN chessboard." 42 | (remove-if (lambda (next) 43 | (or (out-of-bounds (car next) n) 44 | (out-of-bounds (cdr next) n))) 45 | (mapcar (lambda (move) 46 | (cons (+ (car move) (car sq)) 47 | (+ (cdr move) (cdr sq)))) 48 | (knight-moves)))) 49 | 50 | (defun knight-moves () 51 | "Return all moves a knight can make on a chessboard." 52 | '((1 . 2) (2 . 1) (-1 . 2) (2 . -1) (-1 . -2) (-2 . -1) (1 . -2) (-2 . 1))) 53 | -------------------------------------------------------------------------------- /src/90-99 misc/p92.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Von Koch's conjecture 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p92 6 | 7 | (defun von-koch (tree &aux (len (length (graph-nodes tree)))) 8 | "Given a tree with N nodes (hence N - 1 edges), return enumerations (as an alist for each node) of the nodes and 9 | edges of the tree, such that for each edge numbered K, the difference between the node numbers of its nodes equals K." 10 | (when (tree-p tree) 11 | (if (= len 1) 12 | (list (list (cons (car (graph-nodes tree)) 1))) 13 | (bind-edges (graph-edges tree) (range 1 len) (range 1 (1- len)))))) 14 | 15 | (defun bind-edges (edges node-list edge-list &optional acc) 16 | "Bind each edge in EDGES to a number in EDGE-LIST, so that it is the difference between the numbering of its two nodes." 17 | (if (null edges) 18 | acc 19 | (let ((defined (remove-if-not (lambda (n) (assoc n acc)) (nodes (car edges))))) 20 | (case (length defined) 21 | ;; both nodes are defined, check if (car edges) can be associated to a number in edge-list 22 | (2 (when (member (abs (- (assoc (start-node (car edges)) acc) 23 | (assoc (end-node (car edges)) acc))) 24 | edge-list) 25 | (bind-edges (cdr edges) node-list 26 | (remove (abs (- (assoc (start-node (car edges)) acc) 27 | (assoc (end-node (car edges)) acc))) 28 | edge-list) 29 | acc))) 30 | ;; one node is defined, try each possibility for a numbering of (car edges) 31 | (1 (mapcan (lambda (edge-num &aux (n1 (assoc (car defined) acc))) 32 | (mapcar (lambda (n2) 33 | (bind-edges (cdr edges) 34 | (remove n2 node-list) 35 | (remove edge-num edge-list) 36 | (cons (cons (other-node (car edges) (car defined)) n2) acc))) 37 | (intersection (list (+ n1 edge-num) (- n1 edge-num)) node-list))) 38 | edge-list)) 39 | ;; no nodes are defined, try each possibility for a numbering of (car edges) 40 | (T (mapcan (lambda (edge-num) 41 | (mapcar (lambda (ns &aux (n1 (car ns)) (n2 (cdr ns))) 42 | (bind-edges (cdr edges) 43 | (set-difference node-list (list n1 n2)) 44 | (remove edge-num edge-list) 45 | (cons (cons (start-node (car edges)) n1) 46 | (cons (cons (end-node (car edges)) n2) acc)))) 47 | (node-ns edge-num node-list))) 48 | edge-list)))))) 49 | 50 | (defun node-ns (edge-num node-list) 51 | "Return the pairs of node numbers in NODE-LIST whose difference is equal to EDGE-NUM." 52 | (mapcan (lambda (n1) 53 | (mapcar (lambda (n2) (cons n1 n2)) 54 | (intersection (list (+ n1 edge-num) (- n1 edge-num)) node-list))) 55 | node-list)) 56 | -------------------------------------------------------------------------------- /src/90-99 misc/p93.lisp: -------------------------------------------------------------------------------- 1 | ;;;; An arithmetic puzzle 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p93 6 | 7 | (defun find-equations (numbers) 8 | "Given a list of integer numbers, find ways of inserting operators such that the result is a correct equation. 9 | Example: With the list (2 3 5 7 11) we can form the equations (2 - 3 + 5 + 7 = 11) or (2 = [ 3 * 5 + 7 ] / 11)." 10 | ;; break down position of = sign 11 | (when numbers 12 | (remove-duplicates 13 | (mapcar #'prefix-to-infix 14 | (mapcan (lambda (i &aux (sides (split numbers i))) ;p17 15 | ;; consider negations as well (reducing them later is much more cumbersome) 16 | (append (make-equations (car sides) (cadr sides)) 17 | (make-equations (cons (- (caar sides)) (cdar sides)) 18 | (cons (- (caadr sides)) (cdadr sides))) 19 | )) 20 | (range 1 (1- (length numbers))))) ;p22 21 | :test #'equal))) 22 | 23 | (defun make-equations (lhs rhs) 24 | "Return all equations whose left-hand side is formed from LHS and right-hand side from RHS by inserting operators." 25 | (if (< (length lhs) (length rhs)) 26 | (mapcan (lambda (lhs-expr) 27 | (mapcar (lambda (rhs-expr) 28 | (list '= lhs-expr rhs-expr)) 29 | ;; remove all but the expressions whose value is the same as lhs-expr 30 | (remove (eval lhs-expr) (make-exprs rhs) 31 | :test-not #'eql 32 | :key #'eval))) 33 | (make-exprs lhs)) 34 | (mapcan (lambda (rhs-expr) 35 | (mapcar (lambda (lhs-expr) 36 | (list '= lhs-expr rhs-expr)) 37 | ;; remove all but the expressions whose value is the same as rhs-expr 38 | (remove (eval rhs-expr) (make-exprs lhs) 39 | :test-not #'eql 40 | :key #'eval))) 41 | (make-exprs rhs)))) 42 | 43 | (defun make-exprs (numbers) 44 | "Generate all expressions formed by inserting operators to NUMBERS." 45 | (if (= (length numbers) 1) 46 | numbers ;(apply-unary-ops (car numbers)) 47 | ;; split numbers, combine each expression from either partition using a binary operator 48 | (loop for i from 1 to (1- (length numbers)) 49 | for partition = (split numbers i) append 50 | (loop for arg1 in (make-exprs (car partition)) append 51 | (loop for arg2 in (make-exprs (cadr partition)) append 52 | (apply-binary-ops arg1 arg2)))))) 53 | 54 | (defun apply-unary-ops (arg1) 55 | "Apply unary operations to argument." 56 | (list arg1 (list '- arg1))) 57 | 58 | (defun apply-binary-ops (arg1 arg2) 59 | "Apply binary operations to arguments." 60 | (loop for op in '(+ - * /) 61 | if (apply-op op arg1 arg2) 62 | collect it)) 63 | 64 | (defun apply-op (op arg1 arg2) 65 | "Apply operator to arguments, disregarding associativity." 66 | (unless (and (eq op '/) (zerop (eval arg2))) 67 | (list op arg1 arg2))) 68 | 69 | ;;; An aside: converting from lispy arithmetic expressions to infix notation 70 | ;;; Not necessary for the purpose of the program, as the order of numbers stays the same, but truer to the original problem. 71 | 72 | (defparameter *unary-ops* '(-) "Unary operators.") 73 | (defparameter *binary-ops* '(= + - * /) "Binary operators, sorted by precedence.") 74 | (defparameter *op-complements* '((- +) (/ *)) "Match binary operators to the operators they are a complement of.") 75 | 76 | (defun prefix-to-infix (expr) 77 | "Convert a Lisp arithmetic expression in Polish notation into a list of numbers and operators in infix notation. 78 | Example: (+ (* 3 5) (- 2 7)) => (3 * 5 + 2 - 7); (* (+ 3 5) (- 2 7)) => ([ 3 + 5 ] * [ 2 - 7 ])." 79 | (cond ((numberp expr) (list expr)) 80 | ((unary-p expr) expr) 81 | ((binary-p expr) 82 | (append (infix-arg (first expr) (second expr) T) 83 | (cons (first expr) 84 | (infix-arg (first expr) (third expr) NIL)))))) 85 | 86 | (defun infix-arg (op expr lhs &aux (res (prefix-to-infix expr))) 87 | "Optionally add parentheses to the infix notation of EXPR, as an argument to OP." 88 | (if (or (not (binary-p expr)) 89 | (precedes-p op (first expr) lhs)) 90 | res 91 | (cons '[ (append res (list ']))))) 92 | 93 | (defun precedes-p (op1 op2 lhs) 94 | "Return T if an expression of OP2 can be written without parentheses at the LHS/RHS of an expression of OP1." 95 | (or (< (position op1 *binary-ops*) 96 | (position op2 *binary-ops*)) 97 | (if (assoc op1 *op-complements*) 98 | (and lhs 99 | (member op2 (assoc op1 *op-complements*))) 100 | (eq op1 op2)))) 101 | 102 | (defun unary-p (expr) 103 | "Return T if EXPR is the application of a unary operator." 104 | (and (listp expr) 105 | (= (length expr) 2) 106 | (member (first expr) *unary-ops*))) 107 | 108 | (defun binary-p (expr) 109 | "Return T if EXPR is the application of a binary operator." 110 | (and (listp expr) 111 | (= (length expr) 3) 112 | (member (first expr) *binary-ops*))) 113 | 114 | ;; not necessary for the main function of the problem, can still be used for testing etc. 115 | (defun infix-to-prefix (expr &aux output operators) 116 | "Convert an infix arithmetic expression, expressed as a list of numbers, operators and brackets, into a Lisp expression." 117 | ;; shunting yard algorithm, adjusted for Lisp expressions 118 | (do* ((expr expr (cdr expr)) 119 | (item (car expr) (car expr))) 120 | ((null expr)) 121 | (cond ((numberp item) (push item output)) 122 | ((member item *binary-ops*) 123 | (do () 124 | ((or (null operators) 125 | (not (member (car operators) *binary-ops*)) 126 | (precedes-p (car operators) item T))) 127 | ;; apply (pop operators) to output 128 | (let* ((arg2 (pop output)) (arg1 (pop output))) 129 | (push (list (pop operators) arg1 arg2) output))) 130 | (push item operators)) 131 | ((eq item ']) 132 | (push item operators)) 133 | ((eq item '[) 134 | (do () 135 | ((eq (car operators) '])) 136 | ;; apply (pop operators) to output 137 | (let* ((arg2 (pop output)) (arg1 (pop output))) 138 | (push (list (pop operators) arg1 arg2) output))) 139 | (pop operators)))) 140 | ;; load operators into output 141 | (dolist (op operators (car output)) 142 | (let* ((arg2 (pop output)) (arg1 (pop output))) 143 | (push (list op arg1 arg2) output)))) 144 | -------------------------------------------------------------------------------- /src/90-99 misc/p94.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Generating k-regular graphs with n nodes 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p94 6 | 7 | (defun regular-graphs (n k) 8 | "Return all non-isomorphic k-regular graphs with n nodes." 9 | (remove-duplicates 10 | (make-graphs k (range 1 n)) ;p22 11 | :test #'isomorphic-p)) ;p85 12 | 13 | (defun make-graphs (deg nodes &optional (nodes-left nodes) edges) 14 | "Generate all (possibly isomorphic) k-regular graphs with the given nodes." 15 | (if (null nodes-left) 16 | (list (make-graph nodes edges)) ;p80 17 | (mapcan (lambda (comb) 18 | ;; try to connect (car nodes-left) to every element of COMB 19 | ;; if any element of COMB has degree >= DEG or is already connected to (car nodes-left), return NIL 20 | ;; otherwise add the created edges to EDGES and call make-graphs 21 | (and (every (lambda (n) 22 | (< (degree-from-edges n edges) deg)) 23 | comb) 24 | (every (lambda (e) 25 | (set-difference (list (car nodes-left)) 26 | (set-difference (nodes e) comb))) 27 | edges) 28 | (make-graph deg nodes (cdr nodes-left) 29 | (append (mapcar (lambda (n) (cons (car nodes-left) n)) comb) edges)))) 30 | (combinations (cdr nodes-left) 31 | (- deg (degree-from-edges (car nodes-left) edges)))))) 32 | 33 | (defun combinations (set k) 34 | "Return all K-element subsets of SET." 35 | (cond ((= k 0) (list NIL)) 36 | ((null set) NIL) 37 | (T (append (mapcar (lambda (comb) (cons (car set) comb)) 38 | (combinations (cdr set) (1- k))) 39 | (combinations (cdr set) k))))) 40 | 41 | (defun degree-from-edges (node edges) 42 | "Calculate the degree of NODE given the list of edges." 43 | (loop for e in edges 44 | if (member node (nodes e)) 45 | sum 1)) 46 | -------------------------------------------------------------------------------- /src/90-99 misc/p95-p96.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Language processing 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p95 6 | 7 | (defun full-words (number &optional (base 10)) 8 | "Print NUMBER in full words. Example: (full-words 175) => \"one-seven-five\"." 9 | (format nil "~{~a~^-~}" (mapcar #'digit-word (digits number base)))) 10 | 11 | (defun digits (number &optional (base 10) acc) 12 | "Return the digits of NUMBER as a list." 13 | (if (< number base) 14 | (cons number acc) 15 | (multiple-value-bind (div rem) (truncate number base) 16 | (digits div base (cons rem acc))))) 17 | 18 | (defun digit-word (digit) 19 | "Return the word corresponding to DIGIT." 20 | (cdr (assoc number *digit-words*))) 21 | 22 | (defparameter *digit-words* 23 | (mapcar (lambda (d) 24 | (cons d (format nil "~r" d))) 25 | (range 0 9)) ;p22 26 | "An alist mapping each digit to their word representation.") 27 | 28 | ;; Addition: printing numbers in words including teens, hundreds and thousands, not digit by digit 29 | 30 | (defun number-to-word (number &aux (base 10)) 31 | "Return the word representation of NUMBER ≥ 0. Example: (number-to-word 175) => \"one hundred seventy-five\"." 32 | (if (and (< number *hundreds-limit*) (/= (rem number (expt base 3)) 0)) 33 | (multiple-value-bind (div rem) (truncate number (expt base 2)) 34 | ;; could be made into a format directive, but clearer this way 35 | (if (= div 0) 36 | (tens-to-word rem) 37 | (format nil "~a hundred~@[ ~a~]" 38 | (tens-to-word div) 39 | (when (> rem 0) 40 | (tens-to-word rem))))) 41 | (do ((n number) 42 | (c 0 (1+ c)) 43 | res) 44 | ((= n 0) 45 | (format nil "~{~a~^ ~}" res)) 46 | (multiple-value-bind (div rem) (truncate n (expt base 3)) 47 | ;; add rem to list only if nonzero 48 | (when (/= rem 0) 49 | (when (> c 0) 50 | (push (nth (1- c) *thousands*) res)) 51 | (push (number-to-word rem) res)) 52 | ;; if haven't reached the end of thousands 53 | (if (< c (1- (length *thousands*))) 54 | (setf n div) 55 | (progn 56 | (push (car (last *thousands*)) res) 57 | (push (number-to-word div) res) 58 | (setf n 0))))))) 59 | 60 | (defun tens-to-word (number &aux (base 10)) 61 | "Convert 0 ≤ NUMBER ≤ 99 into its word representation. Example: (tens-to-word 43) => \"forty-three\"." 62 | (multiple-value-bind (div rem) (truncate number base) 63 | (format nil "~[~a~;~*~a~:;~2*~a-~1@*~a~]" 64 | div 65 | (second (assoc rem *digits*)) ;ones, print if div = 0 66 | (third (assoc rem *digits*)) ;teens, print if div = 1 67 | (fourth (assoc div *digits*))))) ;tens, print (with ones) if div >= 2 68 | 69 | (defparameter *hundreds-limit* 2000 70 | "Print all numbers less than *HUNDREDS-LIMIT*, except for multiples of 1000, using hundreds instead of thousands. 71 | Example: \"eleven hundred\" for 1100, instead of \"one thousand one hundred\".") 72 | 73 | (defparameter *thousands* 74 | '("thousand" "million" "billion" "trillion" "quadrillion" "quintillion" "sextillion" "septillion" "octillion" "nonillion") 75 | "List of powers of 1000 up to 1000^30.") 76 | 77 | (defparameter *digits* 78 | (mapcar (lambda (d) 79 | (list d 80 | (format nil "~r" d) 81 | (format nil "~r" (+ 10 d)) 82 | (format nil "~r" (* 10 d)))) 83 | (range 0 9)) ;p22 84 | "Alist mapping every digit D to the word representation of D, 1D and D0.") 85 | 86 | ;;; p96 87 | 88 | (defun identifier-p (string &aux (list (coerce string 'list))) 89 | "Return T if STRING represents a valid identifier, represented by the quasi-regex syntax \"*(_?[|])*\"." 90 | (labels ((rest-p (list) 91 | (or (null list) 92 | (and (alphanumericp (car list)) 93 | (rest-p (cdr list))) 94 | (and (char= (car list) #\_) 95 | (cdr list) 96 | (alphanumericp (cadr list)) 97 | (rest-p (cddr list)))))) 98 | (and list 99 | (alpha-char-p (car list)) 100 | (rest-p (cdr list))))) 101 | 102 | ;; Extending the above predicate for general syntax diagrams as in the problem 103 | 104 | ;; A syntax diagram can be represented as a directed graph, expressed in readable list form, that transitions from state to 105 | ;; state based on a recognizer predicate that returns the rest of the given sequence if it is true, and NIL otherwise. 106 | 107 | (defun alt-identifier-p (string) 108 | "Alternate implementation of IDENTIFIER-P using general syntax diagrams." 109 | (funcall (recognizer-predicate 110 | (make-recognizer 111 | `((start end ,(predicate-recognizer #'alpha-char-p)) 112 | (end b ,(at-most-one (lambda (x) (eq x #\_)))) 113 | (b end ,(predicate-recognizer #'alphanumericp))))) 114 | string)) 115 | 116 | (defun make-recognizer (syntax-list &aux (graph (d-readable-graph syntax-list)) 117 | (start (start-state graph)) 118 | (end (end-state graph))) 119 | "Create a recognizer predicate from the given list of directed edges of a syntax diagram. 120 | A valid syntax diagram is composed of nodes, with a unique start node named START and end node named END, 121 | and directed, labeled edges with recognizer predicates as labels." 122 | (and start end 123 | (lambda (string) 124 | ;; breadth-first graph search, allowing for loops as long as the predicate matches 125 | (do ((node start) 126 | (string string) 127 | queue) 128 | ((null queue) 129 | (if (eq node end) 130 | string)) 131 | (let ((added (loop for e in (edges node graph) 132 | for res = (funcall (edge-weight e) string) 133 | if res 134 | collect (cons (end-node e) res)))) 135 | (setf queue (append queue added))) 136 | (let ((pair (pop queue))) 137 | (setf node (car pair) 138 | string (cdr pair))))))) 139 | 140 | (defun start-state (syntax-graph) 141 | "Return the starting state of a given syntax diagram, if any." 142 | (let ((start (remove 'start (graph-nodes syntax-graph) :test-not #'eq))) 143 | (if start 144 | (car start)))) 145 | 146 | (defun end-state (syntax-graph) 147 | "Return the ending state of a given syntax diagram, if any." 148 | (let ((end (remove 'end (graph-nodes syntax-graph) :test-not #'eq))) 149 | (if end 150 | (car end)))) 151 | 152 | (defun predicate-recognizer (pred) 153 | "Generate a recognizer predicate for strings from a predicate for characters." 154 | (lambda (string) 155 | (when (funcall pred (char string 0)) 156 | (subseq string 1)))) 157 | 158 | (defun recognizer-predicate (recognizer) 159 | "Generate a predicate that tests for exactly the strings recognized by RECOGNIZER." 160 | (lambda (string &aux (res (funcall recognizer string))) 161 | (and res (zerop (length res))))) 162 | 163 | (defun at-most-one (pred) 164 | "Generate a recognizer predicate that checks at most one instance for the given predicate for characters." 165 | (lambda (string) 166 | (if (funcall pred (char string 0)) 167 | (subseq string 1) 168 | string))) 169 | 170 | (defun kleene-star (pred) 171 | "Generate a recognizer predicate that checks any number of instances for the given predicate for characters." 172 | (lambda (string) 173 | (if (funcall pred (char string 0)) 174 | (funcall (kleene-star pred) (subseq string 1)) 175 | string))) 176 | 177 | (defconstant id-recognizer #'identity "A recognizer predicate that does nothing.") 178 | 179 | (defun recognizer-union (arg1 arg2) 180 | "Return the union of two recognizers." 181 | (lambda (string &aux (res (funcall arg1 string))) 182 | (if res 183 | res 184 | (funcall arg2 string)))) 185 | 186 | (defun recognizer-compose (arg1 arg2) 187 | "Return the composition of two recognizers." 188 | (lambda (string &aux (res (funcall arg1 string))) 189 | (when res 190 | (funcall arg2 res)))) 191 | 192 | (defun literal-recognizer (literal) 193 | "Generate a recognizer for a literal string." 194 | (if (characterp literal) 195 | (setf literal (make-string 1 :initial-element literal))) 196 | (lambda (string) 197 | (and (<= (length literal) (length string)) 198 | (string= literal (subseq string 0 (length literal))) 199 | (subseq string (length literal))))) 200 | 201 | ;; using recursion to parse context-free and not just regular languages 202 | (defun parentheses (string) 203 | "Recognize a balanced set of parentheses." 204 | (funcall (make-recognizer `((start end ,#'identity) 205 | (start a ,(literal-recognizer "(")) 206 | (a b ,#'parentheses) 207 | (b end ,(literal-recognizer ")")))))) 208 | -------------------------------------------------------------------------------- /src/90-99 misc/p97-p98.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Sudoku solver 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p97 6 | 7 | (defun solve-sudoku (array &optional (spot (next-undefined-spot array))) 8 | "Return solutions to a valid Sudoku puzzle, represented by a 9x9 array with elements either an integer between 1 and 9 or NIL." 9 | (if (null spot) 10 | (list array) 11 | (mapcan (lambda (n &aux (a (copy-seq array))) ;expensive 12 | (setf (aref a (car spot) (cdr spot)) n) 13 | (solve-sudoku a (next-undefined-spot a spot))) 14 | (set-difference (range 1 9) ;p22 15 | (union (row-defined-spots array spot) 16 | (col-defined-spots array spot) 17 | (sqr-defined-spots array spot)))))) 18 | 19 | (defun solve-sudoku-iter (array &aux res (defined-num (defined-num array))) 20 | "Alternate iterative version of SOLVE-SUDOKU." 21 | (do* ((queue (list NIL) (cdr queue)) 22 | (binds (car queue) (car queue)) ;a list containing bindings for spots 23 | (spot (next-undefined-spot array (mapcar #'car binds)) 24 | (next-undefined-spot array (mapcar #'car binds)))) 25 | ((null queue) res) 26 | (if (= (length binds) defined-num) 27 | ;; add valid solution to list 28 | (push (apply-bindings binds array) res) 29 | (setf queue 30 | (append queue 31 | (mapcar (lambda (n) 32 | (cons (cons spot n) binds)) 33 | (set-difference (range 1 9) 34 | (union (row-defined-spots array spot binds) 35 | (col-defined-spots array spot binds) 36 | (sqr-defined-spots array spot binds))))))))) 37 | 38 | (defun apply-bindings (binds array) 39 | "Apply the given bindings to ARRAY." 40 | (setf array (copy-seq array)) 41 | (loop for ((row . col) . n) in binds 42 | do (setf (aref array row col) n)) 43 | array) 44 | 45 | (defun next-undefined-spot (array &optional defined-spots (start (cons 0 0))) 46 | "Return the next spot of ARRAY, read from left to right and from top to bottom, that comes after START and is NIL." 47 | (do ((row (car start)) 48 | (col (cdr start))) 49 | ((= row (array-dimension array 0))) 50 | (unless (or (aref array row col) 51 | (member (cons row col) defined-spots :test #'equal)) 52 | (return (cons row col))) 53 | (if (= (incf col) (array-dimension array 1)) 54 | (setf row (1+ row) col 0)))) 55 | 56 | (defun row-defined-spots (array spot &optional binds) 57 | "Return the numbers on the same row as SPOT in ARRAY that are not NIL." 58 | (loop for col to (array-dimension array 1) 59 | for row = (car spot) 60 | for bind = (assoc (cons row col) binds :test #'equal) 61 | if (aref array row col) 62 | collect it 63 | if bind 64 | collect (cdr bind))) 65 | 66 | (defun col-defined-spots (array spot &optional binds) 67 | "Return the numbers on the same column as SPOT in ARRAY that are not NIL." 68 | (loop for row to (array-dimension array 0) 69 | for col = (cdr spot) 70 | for bind = (assoc (cons row col) binds :test #'equal) 71 | if (aref array row col) 72 | collect it 73 | if bind 74 | collect (cdr bind))) 75 | 76 | (defun sqr-defined-spots (array spot &optional binds) 77 | "Return the numbers on the same 3x3 square as SPOT in ARRAY that are not NIL." 78 | (do ((row (* 3 (floor (car spot) 3) (1+ row))) res) 79 | ((= row (* 3 (ceiling (car spot) 3))) res) 80 | (do ((col (* 3 (floor (cdr spot) 3)) (1+ col))) 81 | ((= col (* 3 (ceiling (cdr spot) 3)))) 82 | (if (aref array row col) 83 | (push (aref array row col) res)) 84 | (if (assoc (cons row col) binds :test #'equal) 85 | (push (assoc (cons row col) binds :test #'equal) res))))) 86 | 87 | (defun print-sudoku (array) 88 | "Print a 9x9 array representing a Sudoku puzzle." 89 | (dotimes (row 9) 90 | ;; horizontal separators 91 | (when (> row 0) 92 | (if (= (rem row 3) 0) 93 | (print "--------+---------+--------") 94 | (print " | | "))) 95 | ;; print each column 96 | (dotimes (col 9) 97 | ;; column separators 98 | (when (> col 0) 99 | (format t " ~[|~] " (rem col 3))) 100 | ;; print array[row, col] if not NIL, else print . 101 | (format t "~[.~;~:*~D~]" (aref array row col))))) 102 | 103 | ;;; p98 104 | 105 | (defun solve-nonogram (rows cols &optional puzzle) 106 | "Solve the nonogram puzzle represented by the given lists of solid lengths across each row and column. 107 | A full cell in a solution of the puzzle will be represented by T, and an empty cell by NIL." 108 | (if (null rows) 109 | (list puzzle) 110 | ;; start from the last row 111 | (mapcan (lambda (row &aux (p (partition-cols cols row))) 112 | ;; if every cell is compatible with the current state of columns 113 | (when (every #'identity (mapcar #'car p)) 114 | (solve-nonogram (butlast rows) 115 | (mapcar #'cdr p) 116 | (cons row puzzle)))) 117 | (generate-rows (car (last rows)) (length cols))))) 118 | 119 | (defun solve-nonogram-iter (rows cols &aux res) 120 | "Alternative iterative version of SOLVE-NONOGRAM." 121 | (do* ((queue (list (cons NIL cols)) (cdr queue)) 122 | (step (car queue) (car queue))) ;a pair of filled rows and a column list 123 | ((null queue) res) 124 | (if (= (length (car step)) (length rows)) 125 | (push (car step) res) 126 | (setf queue 127 | (append queue 128 | (loop for row in (generate-rows (nth (- (length rows) 129 | (length (car step))) 130 | rows) 131 | (length cols)) 132 | for p = (partition-cols (cdr step) row) 133 | if (every #'identity (mapcar #'car p)) 134 | collect (cons (cons row (car step)) 135 | (mapcar #'cdr p)))))))) 136 | 137 | ;; A column is represented as a list of numbers with last element possibly NIL, depending on if the last row can be filled. 138 | 139 | (defun partition-cols (row cols) 140 | "Separate COLS into firsts and rests based on whether row is T at each column." 141 | (loop for cell in row 142 | for col in cols 143 | if cell 144 | collect (cons (column-first col) (column-rest col)) 145 | else 146 | collect (cons T col))) 147 | 148 | (defun column-first (col) 149 | "Return T if a cell in the last row and same column as COL can be filled." 150 | (not (null (car (last col))))) 151 | 152 | (defun column-rest (col) 153 | "Return the rest of COL after the last row has been applied." 154 | (case (car (last col)) 155 | (NIL (butlast col)) ;works also if col is NIL 156 | (1 (append (butlast col) (list NIL))) 157 | (T (append (butlast col) (mapcar #'1- (last col)))))) 158 | 159 | (defun generate-rows (row-list n) 160 | "Collect ways to fill a row with T and NIL based on the given list of lengths." 161 | ;; partition (- n (length row-list)) empty cells into (1+ (length row-list)) solid parts 162 | (mapcar (lambda (partition &aux (rows (row-list))) 163 | (append (make-list (car partition)) 164 | (loop for i to (1- (length row-list)) 165 | for fulls = (pop rows) 166 | for empties = (pop partition) 167 | ;; make sure every intermediate empty block is full 168 | if (or (= i (1- (length row-list))) 169 | (> empties 0)) 170 | append 171 | (append (make-list fulls :initial-element T) 172 | (make-list empties))))) 173 | (partitions (- n (length row-list)) 174 | (1+ (length row-list))))) 175 | 176 | (defun partitions (n k) 177 | "Partition N into K natural numbers, dependent of ordering." 178 | (and (>= n 0) (> k 0) 179 | (do* ((queue (list NIL) (cdr queue)) 180 | (part (car queue) (car queue)) ;an incomplete partition 181 | res) 182 | ((null queue) res) 183 | (if (= (length part) k) 184 | (when (= (reduce #'+ part) n) 185 | (push part res)) 186 | (setf queue 187 | (append queue 188 | (mapcar (lambda (d) 189 | (cons d part)) 190 | (range 0 (- n (reduce #'+ part)))))))))) ;p22 191 | -------------------------------------------------------------------------------- /src/90-99 misc/p99.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Crossword puzzle solver 2 | 3 | (in-package #:99-lisp-problems) 4 | 5 | ;;; p99 6 | 7 | ;; The framework of a crossword puzzle is represented internally as a graph, with nodes representing sites, storing 8 | ;; the coordinates of the starting point, direction and length and (if defined) the contents of the site, and edges 9 | ;; representing the points at which sites intersect. 10 | ;; A site is a list of 4 elements: its starting coordinates, direction (either (cons 1 0) or (cons 0 1)), length and word. 11 | ;; An edge has as its weight a dotted pair representing its coordinates. 12 | 13 | ;; An example string representation of a puzzle is as follows: 14 | ;; ...... . 15 | ;; . . . . 16 | ;; . ..... . 17 | ;; . . . ... 18 | ;; . ... . 19 | ;; ... 20 | 21 | (defun solve-puzzle (word-list puzzle &aux (graph (puzzle-graph puzzle))) 22 | "Solve a crossword puzzle, inputted as a string, and return the solved puzzle as a string." 23 | (when graph 24 | (assign-words word-list graph) 25 | (when graph 26 | (graph-puzzle graph)))) 27 | 28 | (defun assign-words (word-list graph) 29 | "Assign words in the given list to each site of GRAPH, in a way compatible with the intersections of each site." 30 | ;; go through each site, assign words of appropriate length, filter based on intersections 31 | (when (<= (length (graph-nodes graph)) 32 | (length word-list)) 33 | (do* ((stack (list NIL) (cdr stack)) ;stores alists binding sites to words 34 | found) 35 | ((or found (null stack)) 36 | (when found 37 | (loop for (site word) in found 38 | do (setf (fourth site) word) 39 | finally (return T)))) 40 | ;; if (car stack) has a binding for each site 41 | (if (= (length (car stack)) 42 | (length (graph-nodes graph))) 43 | (setf found (car stack)) 44 | (setf stack 45 | (append 46 | (loop with site = (car (set-difference (graph-nodes graph) 47 | (mapcar #'car (car stack)) 48 | :test #'equal)) 49 | for word in (set-difference word-list 50 | (mapcar #'cadr (car stack)) 51 | :test #'equal) 52 | if (and (= (third site) (length word)) 53 | ;; check for intersections 54 | (every (lambda (edge &aux (other (other-node edge site))) 55 | (or (null (assoc other (car stack) :test #'equal)) 56 | (char= (char word (site-index edge site)) 57 | (char (second (assoc other (car stack) :test #'equal)) 58 | (site-index edge other))))) 59 | (edges site graph))) ;p80 60 | collect (cons (list site word) (car stack))) 61 | stack)))))) 62 | 63 | (defun site-index (edge site &aux (start (first site)) (dir (second site)) (meet (edge-weight edge))) ;p80 64 | "Return the index of the intersection represented by EDGE on SITE, assuming SITE lies on that intersection." 65 | (+ (* (car dir) (- (car meet) (car start))) 66 | (* (cdr dir) (- (cdr meet) (cdr start))))) 67 | 68 | (defun puzzle-graph (puzzle &aux matrix (graph (make-graph))) 69 | "Convert the string representation of a puzzle into a graph." 70 | ;; convert puzzle into 2D matrix for easier horizontal/vertical traversal 71 | (with-input-from-string (s puzzle) 72 | (do* ((lst NIL (cons l lst)) 73 | (row 0 (1+ row)) 74 | (col 0 (max col (length l))) 75 | (l (read-line s NIL) (read-line s NIL))) ;updated last for null check 76 | ((null l) 77 | (setf matrix (make-array (list row col) 78 | :initial-contents 79 | ;; expand each row to col 80 | (mapcar (lambda (row-list) 81 | (append row-list 82 | (make-list (- col (length row-list)) 83 | :initial-element #\Space))) 84 | lst)))))) 85 | ;; scan each row and column for sites, add them as nodes to graph 86 | (add-sites matrix graph (cons 0 1)) 87 | (add-sites matrix graph (cons 1 0)) 88 | ;; check for intersections 89 | (destructuring-bind 90 | (horizontal vertical) 91 | (reduce (lambda (node acc) 92 | (if (= (car (second node)) 0) 93 | (push node (first acc)) 94 | (push node (second acc)))) 95 | (graph-nodes graph) 96 | :from-end T 97 | :initial-element (list NIL NIL)) 98 | (dolist (a horizontal) 99 | (dolist (b vertical) 100 | ;; check whether a and b intersect 101 | ;; if they intersect, they must do so at the row of a and column of b 102 | (and 103 | ;; the column of b is within a's bounds 104 | (<= 0 105 | (- (cdr (first b)) 106 | (cdr (first a))) 107 | (1- (third a))) 108 | ;; the row of a is within b's bounds 109 | (<= 0 110 | (- (car (first a)) 111 | (car (first b))) 112 | (1- (third b))) 113 | (push (list a b (cons (car (first a)) 114 | (cdr (first b)))) 115 | (graph-edges graph)))))) 116 | graph) 117 | 118 | (defun add-sites (matrix graph direction) 119 | "Scan MATRIX in the direction specified (either horizontal or vertical) and add the sites found to the nodes of GRAPH." 120 | (dotimes (row (array-dimension matrix (car direction))) ;row if 0, col if 1 121 | (do* ((col 0 (1+ col)) 122 | (cell (if (= (car direction) 0) ;horizontal 123 | (aref matrix row col) 124 | (aref matrix col row))) 125 | site) ;if a site is being read, contains its starting point, current length and current string 126 | ((= col (array-dimension matrix (cdr direction)))) ;col if 0, row if 1 127 | (if (char= cell #\Space) 128 | ;; if a site has ended, add site to nodes, reset site 129 | (and site (> (second site) 1) ;so vertical sites aren't captured as well 130 | (push (list (first site) ;starting coordinates 131 | direction ;the given direction 132 | (second site) ;length 133 | (coerce (third site) 'string) ;word, if any 134 | (graph-nodes graph)) 135 | (setf site NIL))) 136 | ;; start or continue site, with string reset if (aref matrix row col) = #\. 137 | (cond (site 138 | (incf (second site)) 139 | (if (char= cell #\.) 140 | (setf (third site) NIL) 141 | (vector-push cell (third site)))) 142 | (T 143 | (setf site 144 | (list (cons row col) 145 | 1 146 | (unless (char= cell #\.) 147 | (make-array (- (array-dimension matrix 0) row) 148 | :initial-element cell 149 | :fill-pointer 1)))))))))) 150 | 151 | (defun graph-puzzle (graph &aux matrix) 152 | "Convert the graph representation of a puzzle into a string." 153 | ;; create intermediate 2d array 154 | (destructuring-bind 155 | (horizontal vertical) 156 | (reduce (lambda (site acc) 157 | (if (= (car (second site)) 0) 158 | (push site (first acc)) 159 | (push site (second acc)))) 160 | (graph-nodes graph) 161 | :from-end T 162 | :initial-element (list NIL NIL)) 163 | (setf matrix 164 | (make-array 165 | ;; get boundaries 166 | (list (reduce #'max 167 | (mapcar (lambda (site) 168 | (+ (car (first site)) (1- (third site)))) 169 | horizontal)) 170 | (reduce #'max 171 | (mapcar (lambda (site) 172 | (+ (cdr (first site)) (1- (third site)))) 173 | vertical))) 174 | :initial-element #\Space))) 175 | ;; write each site onto matrix 176 | (dolist (site (graph-nodes graph)) 177 | (type-site site matrix)) 178 | ;; convert matrix into string 179 | (format nil "~{~A~^~%~}" 180 | (loop for row to (1- (array-dimension matrix 0)) 181 | collect ;each row as string 182 | (coerce (make-array (array-dimension matrix 1) 183 | :displaced-to matrix 184 | :displaced-index-offset 185 | (* row (array-dimension matrix 1))) 186 | 'string)))) 187 | -------------------------------------------------------------------------------- /src/99-lisp-problems.asd: -------------------------------------------------------------------------------- 1 | (defpackage #:99-lisp-problems 2 | (:use :cl :asdf)) 3 | 4 | (in-package :99-lisp-problems) 5 | 6 | (defsystem 99-lisp-problems 7 | :name "99 Lisp problems" 8 | :description "Solutions to the 99 Prolog problems in Common Lisp" 9 | :author "Ata Deniz Aydin" 10 | :licence "The MIT License" 11 | :components 12 | ((:module lists 13 | :pathname "01-28 lists" 14 | :components ((:file "p01-p07") 15 | (:file "p08-p13" 16 | :depends-on ("p01-p07")) 17 | (:file "p14-p21") 18 | (:file "p22-p28" 19 | :depends-on ("p01-p07" 20 | "p08-p13" 21 | "p14-p21")))) 22 | (:module arithmetic 23 | :pathname "31-41 arithmetic" 24 | :components ((:file "p31-p41" 25 | :depends-on ("p08-p13" 26 | "p22-p28")))) 27 | (:module logic 28 | :pathname "46-50 logic" 29 | :components ((:file "p46-p50"))) 30 | (:module bintrees 31 | :pathname "54-69 bintrees" 32 | :components ((:file "p54-p60" 33 | :depends-on ("p22-p28")) 34 | (:file "p61-p63" 35 | :depends-on ("p22-p28" 36 | "p54-p60")) 37 | (:file "p64-p66" 38 | :depends-on ("p22-p28" 39 | "p54-p60" 40 | "p67-p69")) 41 | (:file "p67-p69"))) 42 | (:module multitrees 43 | :pathname "70-73 multitrees" 44 | :components ((:file "p70-p73"))) 45 | (:module graphs 46 | :pathname "80-89 graphs" 47 | :components ((:file "p80") 48 | (:file "p81-p84" 49 | :depends-on ("p80")) 50 | (:file "p85-p89" 51 | :depends-on ("p80")))) 52 | (:module misc 53 | :pathname "90-99 misc" 54 | :components ((:file "p90-p91" 55 | :depends-on ("p22-p28")) 56 | (:file "p92" 57 | :depends-on ("p22-p28")) 58 | (:file "p93" 59 | :depends-on ("p14-p21" 60 | "p22-p28")) 61 | (:file "p94" 62 | :depends-on ("p22-p28" 63 | "p80" 64 | "p85-p89")) 65 | (:file "p95-p96" 66 | :depends-on ("p22-p28")) 67 | (:file "p97-p98" 68 | :depends-on ("p22-p28")) 69 | (:file "p99" 70 | :depends-on ("p80")))))) 71 | --------------------------------------------------------------------------------