Just another update

Task/Self-referential-sequence/TXR/self-referential-sequence-1.txr

@@ -0,0 +1,59 @@
+@(do
+   ;; Syntactic sugar for calling reduce-left
+   (defmacro reduce-with ((acc init item sequence) . body)
+     ^(reduce-left (lambda (,acc ,item) ,*body) ,sequence ,init))
+
+   ;; Macro similar to clojure's ->> and ->
+  (defmacro opchain (val . ops)
+    ^[[chain ,*[mapcar [iffi consp (op cons 'op)] ops]] ,val])
+
+  ;; Reduce integer to a list of integers representing its decimal digits.
+  (defun digits (n)
+    (if (< n 10)
+      (list n)
+      (opchain n tostring list-str (mapcar (op - @1 #\0)))))
+
+  (defun dcount (ds)
+    (digits (length ds)))
+
+  ;; Perform a look-say step like (1 2 2) --"one 1, two 2's"-> (1 1 2 2).
+  (defun summarize-prev (ds)
+    (opchain ds copy (sort @1 >) (partition-by identity)
+             (mapcar [juxt dcount first]) flatten))
+
+  ;; Take a starting digit string and iterate the look-say steps,
+  ;; to generate the whole sequence, which ends when convergence is reached.
+  (defun convergent-sequence (ds)
+    (reduce-with (cur-seq nil ds [giterate true summarize-prev ds])
+      (if (member ds cur-seq)
+        (return-from convergent-sequence cur-seq)
+        (nconc cur-seq (list ds)))))
+
+  ;; A candidate sequence is one which begins with montonically
+  ;; decreasing digits. We don't bother with (9 0 9 0) or (9 0 0 9);
+  ;; which yield identical sequences to (9 9 0 0).
+  (defun candidate-seq (n)
+    (let ((ds (digits n)))
+      (if [apply >= ds]
+        (convergent-sequence ds))))
+
+  ;; Discover the set of longest sequences.
+  (defun find-longest (limit)
+    (reduce-with (max-seqs nil new-seq [mapcar candidate-seq (range 1 limit)])
+      (let ((cmp (- (opchain max-seqs first length) (length new-seq))))
+        (cond ((> cmp 0) max-seqs)
+              ((< cmp 0) (list new-seq))
+              (t (nconc max-seqs (list new-seq)))))))
+
+  (defvar *results* (find-longest 1000000))
+
+  (each ((result *results*))
+    (flet ((strfy (list) ;; (strfy '((1 2 3 4) (5 6 7 8))) -> ("1234" "5678")
+             (mapcar [chain (op mapcar tostring) cat-str] list)))
+      (let* ((seed (first result))
+             (seeds (opchain seed perm uniq (remove-if zerop @1 first))))
+        (put-line `Seed value(s): @(strfy seeds)`)
+        (put-line)
+        (put-line `Iterations: @(length result)`)
+      (put-line)
+      (put-line `Sequence: @(strfy result)`)))))

Task/Self-referential-sequence/TXR/self-referential-sequence-2.txr

@@ -0,0 +1,32 @@
+@(do
+   (defun count-and-say (str)
+     (let* ((s [sort (copy-str str) <])
+            (out `@[s 0]0`))
+       (each ((x s))
+         (if (eql x [out -1])
+           (inc [out -2])
+           (set out `@{out}1@x`)))
+       out))
+
+  (defun ref-seq-len (n : doprint)
+    (let ((s (tostring n)) hist)
+      (while t
+        (push s hist)
+        (if doprint (pprinl s))
+        (set s (count-and-say s))
+        (each ((item hist)
+               (i (range 0 2)))
+          (when (equal s item)
+            (return-from ref-seq-len (length hist)))))))
+
+  (defun find-longest (top)
+    (let (nums (len 0))
+      (each ((x (range 0 top)))
+        (let ((l (ref-seq-len x)))
+          (when (> l len) (set len l) (set nums nil))
+          (when (= l len) (push x nums))))
+      (list nums len)))
+
+  (let ((r (find-longest 1000000)))
+    (format t "Longest: ~a\n" r)
+    (ref-seq-len (first (first r)) t)))

Task/Self-referential-sequence/TXR/self-referential-sequence-3.txr

@@ -0,0 +1,47 @@
+@(do
+   ;; Macro very similar to Racket's for/fold
+   (defmacro for-accum (accum-var-inits each-vars . body)
+     (let ((accum-vars [mapcar first accum-var-inits])
+           (block-sym (gensym))
+           (next-args [mapcar (ret (progn @rest (gensym))) accum-var-inits])
+           (nvars (length accum-var-inits)))
+       ^(let ,accum-var-inits
+          (flet ((iter (,*next-args)
+                   ,*[mapcar (ret ^(set ,@1 ,@2)) accum-vars next-args]))
+            (each ,each-vars
+              ,*body)
+            (list ,*accum-vars)))))
+
+   (defun next (s)
+     (let ((v (vector 10 0)))
+       (each ((c s))
+         (inc [v (- #\9 c)]))
+       (cat-str
+         (collect-each ((x v)
+                        (i (range 9 0 -1)))
+            (when (> x 0)
+              `@x@i`)))))
+
+   (defun seq-of (s)
+     (for* ((ns ()))
+           ((not (member s ns)) (reverse ns))
+           ((push s ns) (set s (next s)))))
+
+   (defun sort-string (s)
+     [sort (copy s) >])
+
+   (tree-bind (len nums seq)
+     (for-accum ((*len nil) (*nums nil) (*seq nil))
+                ((n (range 1000000 0 -1))) ;; start at the high end
+       (let* ((s (tostring n))
+              (sorted (sort-string s)))
+         (if (equal s sorted)
+           (let* ((seq (seq-of s))
+                  (len (length seq)))
+             (cond ((or (not *len) (> len *len)) (iter len (list s) seq))
+                   ((= len *len) (iter len (cons s *nums) seq))))
+           (iter *len
+                 (if (and *nums (member sorted *nums)) (cons s *nums) *nums)
+                 *seq))))
+     (put-line `Numbers: @{nums ", "}\nLength: @len`)
+     (each ((n seq)) (put-line `  @n`)))