From fe4b58e4bd4be70aca5e2d2c5ec00fc85cc3608c Mon Sep 17 00:00:00 2001
From: Guy Gastineau <strings.stringsandstrings@gmail.com>
Date: Wed, 15 Jun 2022 09:49:42 -0400
Subject: [PATCH] Fix acronym with portable example solution.

With the new portable example solution for acronym it can be included
in the ci tests, so that all non-deprecated exercises are tested in
the ci tests.
---
 Makefile                                     |  6 ++--
 exercises/practice/acronym/.meta/example.scm | 33 +++++++++++++++++---
 2 files changed, 30 insertions(+), 9 deletions(-)

diff --git a/Makefile b/Makefile
index c2f13889..ed2d47c4 100644
--- a/Makefile
+++ b/Makefile
@@ -98,10 +98,8 @@ track : $(track-requirements)
 # send a list of implementations to run stub-makefile tests on
 ci :
 	#echo "(run-ci '($(implementations)))" | $(chez) -q "script/ci.ss"
-	# The acronym example code only works for guile.  Currently, examples
-	# must pass for both chez and guile.  list-ops and robot-name are both
-	# deprecated anyway.
-	echo "(run-all-tests 'list-ops 'robot-name 'acronym)" | $(chez) -q script/ci.ss
+	# list-ops and robot-name are deprecated, and their tests will fail.
+	echo "(run-all-tests 'list-ops 'robot-name)" | $(chez) -q script/ci.ss
 
 clean :
 	find . -name "*.so" -exec rm {} \;
diff --git a/exercises/practice/acronym/.meta/example.scm b/exercises/practice/acronym/.meta/example.scm
index 5519b69c..ee87adaa 100644
--- a/exercises/practice/acronym/.meta/example.scm
+++ b/exercises/practice/acronym/.meta/example.scm
@@ -1,7 +1,30 @@
-(use-modules (ice-9 regex))
+(import (rnrs))
 
 (define (acronym text)
-  (apply (compose string-upcase string-append)
-         (map (lambda (ss)
-                (string-take (match:substring ss) 1))
-              (list-matches "[[:alpha:]|']+" text))))
+  (with-output-to-string
+    (lambda ()
+      (let go ((xs (string->list text)))
+        (let-values (((word rest)
+                      (snoc-while relevant? (drop-while not-relevant? xs))))
+          (unless (null? word)
+            (put-char (current-output-port) (char-upcase (car word))))
+          (unless (null? rest)
+            (go rest)))))))
+
+(define (relevant? c)
+  (or (char-alphabetic? c) (char=? c #\')))
+
+(define (not-relevant? c)
+  (not (relevant? c)))
+
+(define (drop-while p xs)
+  (cond
+   ((null? xs) xs)
+   ((p (car xs)) (drop-while p (cdr xs)))
+   (else xs)))
+
+(define (snoc-while p xs)
+  (let go ((xs* xs) (taken '()))
+    (if (and (not (null? xs*)) (p (car xs*)))
+        (go (cdr xs*) (cons (car xs*) taken))
+        (values (reverse taken) xs*))))