From df96b1f07ea1d71f07061dafac79c0b6da955ca2 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@unquote>
Date: Fri, 11 Apr 2008 12:59:47 +0200
Subject: [PATCH] add "related posts" foo

* tekuti/page-helpers.scm (post-sidebar): New function, pops up a sidebar
  for related posts.

* tekuti/page.scm (page-show-post): Show the post sidebar.

* tekuti/tags.scm (compute-related-posts): New function, computes the set
  of related posts based on the number of tags which they share in
  common.
---
 tekuti/page-helpers.scm | 16 +++++++++++++++-
 tekuti/page.scm         |  4 ++--
 tekuti/tags.scm         | 25 ++++++++++++++++++++++++-
 3 files changed, 41 insertions(+), 4 deletions(-)

diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm
index 3b73922..6937bdd 100644
--- a/tekuti/page-helpers.scm
+++ b/tekuti/page-helpers.scm
@@ -29,6 +29,7 @@
   #:use-module (tekuti util)
   #:use-module (tekuti git)
   #:use-module (tekuti post)
+  #:use-module (tekuti tags)
   #:use-module (tekuti comment)
   #:use-module (tekuti url)
   #:use-module (tekuti request)
@@ -37,7 +38,7 @@
   #:export (relurl rellink redirect post-url
             published-posts
             post-editing-form
-            sidebar-ul main-sidebar tag-cloud
+            sidebar-ul main-sidebar tag-cloud post-sidebar
             post-link admin-post-link admin-post-redirect
             show-post with-authentication
             atom-header atom-entry))
@@ -222,6 +223,19 @@
          (ul (li (@ (style "line-height: 150%"))
                  ,@(tag-cloud (top-tags index 30))))))))
 
+(define (post-sidebar post index)
+  (sidebar-ul
+   `((li (h2 (a (@ (href ,(relurl "feed/atom")))
+                "subscribe "
+                (img (@ (src ,(relurl "wp-content/feed-icon-14x14.png"))
+                        (alt "[feed]")))
+                )))
+     (li (h2 "related")
+         (ul ,@(map (lambda (post-and-tags)
+                      `(li (@ (style "margin-top: 5px"))
+                           ,(post-link (car post-and-tags))))
+                    (take-max (compute-related-posts post index) 10)))))))
+
 (define (with-authentication request thunk)
   (if (request-authenticated? request)
       (thunk)
diff --git a/tekuti/page.scm b/tekuti/page.scm
index bf36ca5..aec265e 100644
--- a/tekuti/page.scm
+++ b/tekuti/page.scm
@@ -52,7 +52,6 @@
             page-show-tag
             page-debug 
             page-search 
-            page-show-post 
             page-feed-atom
             page-debug
             page-not-found))
@@ -185,7 +184,8 @@
     => (lambda (post)
          (rcons* request
                  'title (string-append (post-title post) " -- " *title*)
-                 'body (show-post post #t))))
+                 'body `(,(post-sidebar post index)
+                         ,(show-post post #t)))))
    (else
     (page-not-found request index))))
 
diff --git a/tekuti/tags.scm b/tekuti/tags.scm
index 466805c..50e79be 100644
--- a/tekuti/tags.scm
+++ b/tekuti/tags.scm
@@ -31,7 +31,7 @@
   #:use-module (tekuti post)
   #:use-module (tekuti git)
   #:use-module ((srfi srfi-1) #:select (filter))
-  #:export (tag-link reindex-tags))
+  #:export (tag-link compute-related-posts reindex-tags))
 
 (define (tag-link tagname)
   `(a (@ (href ,(string-append *public-url-base* "tags/"
@@ -49,5 +49,28 @@
      posts)
     hash))
 
+(define (compute-related-posts post index)
+  (let ((hash (assq-ref index 'tags))
+        (master (assq-ref index 'master)))
+    (if hash
+        (let ((accum (make-hash-table)))
+          (for-each
+           (lambda (tag)
+             (for-each
+              (lambda (key)
+                (if (not (equal? key (post-key post)))
+                    (hash-push! accum key tag)))
+              (or (hash-ref hash tag) '())))
+           (post-tags post))
+          (dsu-sort (dsu-sort
+                     (hash-fold
+                      (lambda (key tags rest)
+                        (acons (post-from-key master key) tags rest))
+                      '() accum)
+                     (lambda (x) (post-timestamp (car x)))
+                     >)
+                    length >))
+        '())))
+
 (define (reindex-tags old-index index)
   (compute-tags (filter post-published? (assq-ref index 'posts))))