aliens/tekuti
1
0
Fork 0
Code Activity

add related-tags clouds to tag/foo pages

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2008-04-12 18:33:34 +02:00
parent 2f7780b552
commit cbfce24dc1
3 changed files with 34 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
tekuti/page-helpers.scm
View file

@ -38,7 +38,8 @@
#:export (relurl rellink redirect post-url #:export (relurl rellink redirect post-url
published-posts published-posts
post-editing-form 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 post-link admin-post-link admin-post-redirect
show-post with-authentication show-post with-authentication
atom-header atom-entry)) atom-header atom-entry))
@ -236,6 +237,11 @@
,(post-link (car post-and-tags)))) ,(post-link (car post-and-tags))))
(take-max (compute-related-posts post index) 10))))))) (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) (define (with-authentication request thunk)
(if (request-authenticated? request) (if (request-authenticated? request)
(thunk) (thunk)

3
tekuti/page.scm
View file

@ -267,7 +267,8 @@
'title (string-append "posts tagged \"" tag "\"") 'title (string-append "posts tagged \"" tag "\"")
'body `((h2 "posts tagged \"" ,tag "\"") 'body `((h2 "posts tagged \"" ,tag "\"")
,@(map (lambda (post) `(p ,(post-link post))) ,@(map (lambda (post) `(p ,(post-link post)))
posts))) posts)
,(related-tag-cloud tag index)))
(rcons* request (rcons* request
'status 404 'status 404
'body `((h2 "Unknown tag " ,tag) 'body `((h2 "Unknown tag " ,tag)

26
tekuti/tags.scm
View file

@ -31,7 +31,9 @@
#:use-module (tekuti post) #:use-module (tekuti post)
#:use-module (tekuti git) #:use-module (tekuti git)
#:use-module ((srfi srfi-1) #:select (filter)) #: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) (define (tag-link tagname)
`(a (@ (href ,(string-append *public-url-base* "tags/" `(a (@ (href ,(string-append *public-url-base* "tags/"
@ -72,5 +74,27 @@
length >)) 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) (define (reindex-tags old-index index)
(compute-tags (filter post-published? (assq-ref index 'posts)))) (compute-tags (filter post-published? (assq-ref index 'posts))))