From cbfce24dc1bf70065e1e2d66076b7c7d059284c6 Mon Sep 17 00:00:00 2001
From: Andy Wingo
Date: Sat, 12 Apr 2008 18:33:34 +0200
Subject: add related-tags clouds to tag/foo pages

* tekuti/page-helpers.scm (related-tag-cloud): New function, shows a
  tag-relative tag cloud.

* tekuti/page.scm (page-show-tag): Add a cloud of related tags.

* tekuti/tags.scm (compute-related-tags): New proc to show related tags.

---
 tekuti/page-helpers.scm |  8 +++++++-
 tekuti/page.scm         |  3 ++-
 tekuti/tags.scm         | 26 +++++++++++++++++++++++++-
 3 files changed, 34 insertions(+), 3 deletions(-)

diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm
index be89ea1..fdafae7 100644
--- a/tekuti/page-helpers.scm
+++ b/tekuti/page-helpers.scm
@@ -38,7 +38,8 @@
   #:export (relurl rellink redirect post-url
             published-posts
             post-editing-form
-            sidebar-ul main-sidebar top-tags tag-cloud post-sidebar
+            sidebar-ul top-tags tag-cloud
+            main-sidebar post-sidebar related-tag-cloud
             post-link admin-post-link admin-post-redirect
             show-post with-authentication
             atom-header atom-entry))
@@ -236,6 +237,11 @@
                            ,(post-link (car post-and-tags))))
                     (take-max (compute-related-posts post index) 10)))))))
 
+(define (related-tag-cloud tag index)
+  `(div (@ (id "tag-cloud"))
+        (h2 "related tags")
+        ,@(tag-cloud (compute-related-tags tag index))))
+
 (define (with-authentication request thunk)
   (if (request-authenticated? request)
       (thunk)
diff --git a/tekuti/page.scm b/tekuti/page.scm
index 372af01..d5fd439 100644
--- a/tekuti/page.scm
+++ b/tekuti/page.scm
@@ -267,7 +267,8 @@
                 'title (string-append "posts tagged \"" tag "\"")
                 'body `((h2 "posts tagged \"" ,tag "\"")
                         ,@(map (lambda (post) `(p ,(post-link post)))
-                               posts)))
+                               posts)
+                        ,(related-tag-cloud tag index)))
         (rcons* request
                 'status 404
                 'body `((h2 "Unknown tag " ,tag)
diff --git a/tekuti/tags.scm b/tekuti/tags.scm
index 50e79be..fde187b 100644
--- a/tekuti/tags.scm
+++ b/tekuti/tags.scm
@@ -31,7 +31,9 @@
   #:use-module (tekuti post)
   #:use-module (tekuti git)
   #:use-module ((srfi srfi-1) #:select (filter))
-  #:export (tag-link compute-related-posts reindex-tags))
+  #:export (tag-link
+            compute-related-posts compute-related-tags
+            reindex-tags))
 
 (define (tag-link tagname)
   `(a (@ (href ,(string-append *public-url-base* "tags/"
@@ -72,5 +74,27 @@
                     length >))
         '())))
 
+(define (compute-related-tags tag index)
+  (let ((hash (assq-ref index 'tags))
+        (master (assq-ref index 'master)))
+    (if hash
+        (let ((accum (make-hash-table)))
+          (for-each
+           (lambda (key)
+             (for-each
+              (lambda (other-tag)
+                (if (not (equal? other-tag tag))
+                    (hash-push! accum other-tag key)))
+              (post-tags (post-from-key master key))))
+           (or (hash-ref hash tag) '()))
+          (dsu-sort
+           (hash-fold
+            (lambda (tag keys rest)
+              (acons tag (length keys) rest))
+            '() accum)
+           car
+           string<?))
+        '())))
+
 (define (reindex-tags old-index index)
   (compute-tags (filter post-published? (assq-ref index 'posts))))
-- 
cgit v1.2.3-54-g00ecf