# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1579545669 18000
# Node ID 8f6ef53eac5561d349a8dd33796898446f01e86d
# Parent  870270771fde01132d41ec379c3dcc97911134cd
ASPC, portability fixes

diff -r 870270771fde -r 8f6ef53eac55 src/package.lisp
--- a/src/package.lisp	Sun Jan 19 21:14:53 2020 -0500
+++ b/src/package.lisp	Mon Jan 20 13:41:09 2020 -0500
@@ -31,7 +31,7 @@
 
     :Σ :Π :binomial-coefficient
 
-    :returning-final
+    :returning-final :summing* :multiplying*
 
     :read-lines
     :read-fasta
diff -r 870270771fde -r 8f6ef53eac55 src/problems/aspc.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/aspc.lisp	Mon Jan 20 13:41:09 2020 -0500
@@ -0,0 +1,13 @@
+(defpackage :rosalind/aspc (:use :cl :rosalind :losh :iterate))
+(in-package :rosalind/aspc)
+
+
+(define-problem aspc (data stream) "6 3" "42"
+  (let ((n (read data))
+        (m (read data)))
+    (iterate
+      (for k :from m :to n)
+      (u:summing* (u:binomial-coefficient n k) :modulo 1000000))))
+
+
+#; Scratch --------------------------------------------------------------------
diff -r 870270771fde -r 8f6ef53eac55 src/problems/trie.lisp
--- a/src/problems/trie.lisp	Sun Jan 19 21:14:53 2020 -0500
+++ b/src/problems/trie.lisp	Mon Jan 20 13:41:09 2020 -0500
@@ -67,6 +67,13 @@
 
 
 ;;;; Problem ------------------------------------------------------------------
+(defun sorted-children (node)
+  ;; Need this for deterministic test output.
+  (_ node
+    trie-node-children
+    alexandria:hash-table-alist
+    (sort _ #'string< :key #'car)))
+
 (defun trie-adjacency-list (root)
   (gathering
     (let ((i 0)
@@ -75,7 +82,7 @@
                (alexandria:ensure-gethash node numbers (incf i))))
         (recursively ((node root))
           (iterate
-            (for (ch child) :in-hashtable (trie-node-children node))
+            (for (ch . child) :in (sorted-children node))
             (gather (list (n node) (n child) ch))
             (recur child)))))))
 
diff -r 870270771fde -r 8f6ef53eac55 src/utils.lisp
--- a/src/utils.lisp	Sun Jan 19 21:14:53 2020 -0500
+++ b/src/utils.lisp	Mon Jan 20 13:41:09 2020 -0500
@@ -283,6 +283,28 @@
        (finally (return ,result))
        (setf ,result ,form))))
 
+(defmacro-clause (SUMMING* form &optional INTO var MODULO divisor INITIAL-VALUE n)
+  "Like vanilla `summing`, but with more options."
+  (let ((result (or var iterate::*result-var*)))
+    (with-gensyms (mod)
+      `(progn
+         (with ,result = ,(or n 0))
+         ,@(if divisor
+             `((with ,mod = ,divisor)
+               (setf ,result (mod (+ ,result ,form) ,mod)))
+             `((incf ,result ,form)))))))
+
+(defmacro-clause (MULTIPLYING* form &optional INTO var MODULO divisor INITIAL-VALUE n)
+  "Like vanilla `multiplying`, but using `*` and with more options."
+  (let ((result (or var iterate::*result-var*)))
+    (with-gensyms (mod)
+      `(progn
+         (with ,result = ,(or n 1))
+         ,@(if divisor
+             `((with ,mod = ,divisor)
+               (setf ,result (mod (* ,result ,form) ,mod)))
+             `((setf ,result (* ,result ,form))))))))
+
 
 ;;;; Readers ------------------------------------------------------------------
 (defun read-lines (stream)
@@ -425,37 +447,49 @@
 
 
 ;;;; Output -------------------------------------------------------------------
-(defun float-string (float-or-floats &optional (precision 3))
+(defun float-string (float-or-floats &optional (places 3))
   "Return a string of `float-or-floats` in the format Rosalind wants.
 
   `float-or-floats` can be a number, list, vector, or 2D array.
 
-  Each float will be printed with `precision` digits after the decimal point.
+  Each float will be printed with `places` digits after the decimal point.
 
   If a list or vector is given, the floats will be separated by a space.
 
   If a two-dimensional array is given, the rows will be separated by newlines.
 
   "
-  (with-output-to-string (s)
-    (flet ((p (float &optional space)
-             (format s "~,VF~:[~; ~]" precision float space)))
-      (etypecase float-or-floats
-        ((or number list)
-         (loop :for (float . more) :on (alexandria:ensure-list float-or-floats)
-               :do (p float more)))
-        ((array * (*))
-         (loop :with last = (1- (length float-or-floats))
-               :for i :from 0
-               :for f :across float-or-floats
-               :do (p f (< i last))))
-        ((array * (* *))
-         (destructuring-bind (rows cols) (array-dimensions float-or-floats)
-           (dotimes (r rows)
-             (dotimes (c cols)
-               (p (aref float-or-floats r c) (< c (1- cols))))
-             (when (< r (1- rows))
-               (terpri s)))))))))
+  (let ((precision (expt 10.0d0 places)))
+    (with-output-to-string (s)
+      ;; Rosalind's examples use half-up style rounding.  I think their answer
+      ;; checking will tolerate half-even, but in order to get consistent test
+      ;; output we need consistent rounding.  Unfortunately format's ~F allows
+      ;; an implementation-specific rounding strategy, so we have to hack this
+      ;; in ourselves, and we may as well match Rosalind.  Sigh.
+      (labels ((round-half-up (float)
+                 (_ float
+                   (* _ precision)
+                   (+ _ 0.5d0)
+                   floor
+                   (/ _ precision)))
+               (p (float &optional space)
+                 (format s "~,VF~:[~; ~]" places (round-half-up float) space)))
+        (etypecase float-or-floats
+          ((or number list)
+           (loop :for (float . more) :on (alexandria:ensure-list float-or-floats)
+                 :do (p float more)))
+          ((array * (*))
+           (loop :with last = (1- (length float-or-floats))
+                 :for i :from 0
+                 :for f :across float-or-floats
+                 :do (p f (< i last))))
+          ((array * (* *))
+           (destructuring-bind (rows cols) (array-dimensions float-or-floats)
+             (dotimes (r rows)
+               (dotimes (c cols)
+                 (p (aref float-or-floats r c) (< c (1- cols))))
+               (when (< r (1- rows))
+                 (terpri s))))))))))
 
 
 ;;;; Testing ------------------------------------------------------------------