Initial commit.

Signed-off-by: Andreas Widen <andreas@harmonicflow.org>

6 files changed, 226 insertions, 0 deletions

diff --git a/apps/aux/lists.scm b/apps/aux/lists.scm
new file mode 100644
index 0000000..634d1e4
--- /dev/null
+++ b/apps/aux/lists.scm
@@ -0,0 +1,67 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux lists)
+  #:use-module (apps aux numbers)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-27)
+  #:export (list-group
+	    list-slice
+	    rest
+            separate
+            take-random))
+
+
+(define (list-group los limit)
+  (map (lambda (index)
+	 (list-slice los index (+ index limit)))
+       ;; TODO: Use a skip-count procedure instead of iota.
+       (iota (ceiling (/ (length los) limit)) 0 limit)))
+
+
+(define* (list-slice los index-a #:optional (index-b #false))
+  (let ((start index-a)
+	(end (if (or (not index-b) (> index-b (length los)))
+		 (- (length los) 1)
+		 (- index-b 1))))
+    (map (lambda (index)
+	   (list-ref los index))
+	 (range index-a end))))
+
+
+(define (rest los)
+  (cond ((<= (length los) 1) (list))
+	(else (list-tail los 1))))
+
+
+(define (separate los separator)
+  "Return a list with the elements of LOS separated by SEPARATOR.
+
+   LOS (list)
+     A list of s-expressions.
+
+   SEPARATOR (s-expression)
+     Any s-expression that will be added between the elements of the
+     given list.
+
+   RETURN VALUE (list)
+     A list of s-expressions."
+  (cond ((or (null? los) (= (length los) 1)) los)
+	(else
+	 (cons (first los)
+	       (cons separator (separate (rest los) separator))))))
+
+(define (take-random list n)
+  "Return a list containing N different elements from LIST, if
+possible, chosen randomly and evenly distributed.  If LIST has less
+than N elements, the result is a permutation of LIST."
+  (let loop ((list list)
+             (n n)
+             (len (length list)))
+    (if (<= (min n len) 0)
+        '()
+        (let ((r (random-integer len)))
+          (cons (list-ref list r)
+                (loop (append (take list r)
+                              (drop list (1+ r)))
+                      (- len 1)
+                      (- n 1)))))))
diff --git a/apps/aux/numbers.scm b/apps/aux/numbers.scm
new file mode 100644
index 0000000..6c83dcb
--- /dev/null
+++ b/apps/aux/numbers.scm
@@ -0,0 +1,31 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux numbers)
+  #:use-module (srfi srfi-1)
+  #:export (minus-one
+	    plus-one
+	    range))
+
+
+(define (minus-one n)
+  "Return N-1."
+  (- n 1))
+
+
+(define (plus-one n)
+  "Return N+1."
+  (+ n 1))
+
+
+(define (range a b)
+  "Return the list of integers in the range [A, B].
+
+   A (integer)
+
+   B (integer)
+
+   RETURN VALUE (list of integers)
+     For example, for the range [-2, 3], return
+     (list -2 -1 0 1 2 3)."
+  (cond ((zero? (- a b)) (cons a (list)))
+	(else (cons a (range (plus-one a) b)))))
diff --git a/apps/aux/strings.scm b/apps/aux/strings.scm
new file mode 100644
index 0000000..7004721
--- /dev/null
+++ b/apps/aux/strings.scm
@@ -0,0 +1,12 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux strings)
+  #:export (string-summarize))
+
+
+(define (string-summarize string n)
+  "Return an extract of N words from the given STRING."
+  (let ((words (string-split string #\space)))
+    (if (<= (length words) n)
+	string
+	(string-join (list-head words n) " "))))
diff --git a/apps/aux/sxml.scm b/apps/aux/sxml.scm
new file mode 100644
index 0000000..531cdee
--- /dev/null
+++ b/apps/aux/sxml.scm
@@ -0,0 +1,23 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux sxml)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (sxml->string*))
+
+
+(define (sxml->string* tree)
+  "Flatten tree by dismissing tags and attributes, and return the resulting
+string."
+  (define (sxml->strings tree)
+    (match tree
+      (((? symbol?) ('@ _ ...) body ...)
+       (append-map sxml->strings `(" " ,@body " ")))
+      (((? symbol?) body ...)
+       (append-map sxml->strings `(" " ,@body " ")))
+      ((? string?)
+       (list tree))
+      ((lst ...)
+       (sxml->strings `(div ,@lst)))))
+
+  (string-concatenate (sxml->strings tree)))
diff --git a/apps/aux/system.scm b/apps/aux/system.scm
new file mode 100644
index 0000000..ee9a5a3
--- /dev/null
+++ b/apps/aux/system.scm
@@ -0,0 +1,32 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux system)
+  #:export (path-join))
+
+
+;;;
+;;; Procedures.
+;;;
+
+(define (path-join . parts)
+  "Return a system path composed of the given PARTS.
+
+   PARTS (strings)
+     A succession of strings representing parts of a file system path.
+
+     To indicate an absolute path, use an empty string as the first
+     part. For example:
+
+     (path-join '' 'docs' 'manual')
+     => '/docs/manual'
+
+     To end the path with a slash, use an empty string as the last
+     part. For example:
+
+     (path-join '' 'docs' 'manual' '')
+     => '/docs/manual/'
+
+   RETURN VALUE (string)
+     A string representing a file system path."
+  (cond ((equal? parts '("")) "/") ; Root directory
+	(else (string-join parts file-name-separator-string))))
diff --git a/apps/aux/web.scm b/apps/aux/web.scm
new file mode 100644
index 0000000..fec6b4c
--- /dev/null
+++ b/apps/aux/web.scm
@@ -0,0 +1,61 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux web)
+  #:use-module (srfi srfi-1)
+  #:export (slugify
+	    url-path-join))
+
+
+;;;
+;;; Variables.
+;;;
+
+(define char-set:slug
+  (char-set-union char-set:letter+digit (char-set #\-)))
+
+
+
+;;;
+;;; Procedures.
+;;;
+
+(define (slugify text)
+  "Return TEXT as a slug.
+
+   Reserved characters for Internationalized Resource Identifiers
+   (IRIs) and common reserved characters for file names are removed
+   using the SLUG_FORBIDDEN constant as reference.
+
+   TEXT (string)
+     Some text. For example: Biology, Human anatomy.
+
+   RETURN VALUE (string)
+     A slug-like string. For example: biology, human-anatomy."
+  (string-join
+   (map (lambda (s) (string-filter char-set:slug s))
+	(string-split (string-downcase text) char-set:whitespace))
+   "-"))
+
+
+(define (url-path-join . parts)
+  "Return a URL path composed of the given PARTS.
+
+   PARTS (strings)
+     A succession of strings that represent parts of a URL path.
+
+     To indicate an absolute path, use an empty string as the first
+     part. For example:
+
+     (url-path-join '' 'docs' 'manual')
+     => '/docs/manual'
+
+     To end the path with a slash, use an empty string as the last
+     part. For example:
+
+     (url-path-join '' 'docs' 'manual' '')
+     => '/docs/manual/'
+
+   RETURN VALUE (string)
+     A string representing a URL path."
+  (cond ((equal? parts '("")) "/") ; Root directory
+	(else (string-join parts "/"))))