(load (string-append laml-dir "laml.scm")) (laml-style "simple-html4.01-transitional-validating")![]()
![]()
(define language-preference 'english) ; ---------------------------------------------------- ; Bookmark title and data![]()
![]()
(define page-title "Part of Kurt Nørmark's Bookmarks")![]()
![]()
(define bookmarks (file-read (string-append (startup-directory) "bookmark-sample.lsp"))) ; ---------------------------------------------------- ; Common functions![]()
![]()
(define (bookmark-categories bookmark-list) (bookmark-categories-iterate bookmark-list '())) ; Selectors![]()
![]()
(define bookmark-title-of (make-selector-function 2))![]()
![]()
(define bookmark-url-of (make-selector-function 3))![]()
![]()
![]()
(define bookmark-category-of (make-selector-function 4))![]()
![]()
(define bookmark-comment-of (make-selector-function 5))![]()
![]()
(define (bookmark-title-of-non-blank bm) (let ((bmt (bookmark-title-of bm))) (if (blank-string? bmt) "?" bmt))) ; Constructor![]()
![]()
(define (make-bookmark ttl url cat com) (list 'bookmark ttl url cat com)) ; -------------------------------------------------------- ; ; The list of frame widths![]()
![]()
(define frame-width-list '(200 *))![]()
![]()
;; frameset-page Write the index file (write-html '(raw) ;(html (head ;
(title "Bookmark Browser") ;
) (frameset ;
(frame 'name "bookmark-categories" 'src "bookmark-categories.html" 'scrolling "auto") (frame 'name "bookmark-main" 'src "bookmark-contents.html" 'scrolling "auto") 'cols (list-to-string (map as-string frame-width-list) ",") ;
)) ) ; A procedure that makes an empty x page.
![]()
![]()
(define (make-empty-page! x) (write-html '(raw) (html (head (title x)) (body (h3 x))) (in-startup-directory (string-append x ".html")))) (make-empty-page! "bookmark-categories") (make-empty-page! "bookmark-contents") ; -------------------------------------------------------------- ; THE LEFT HAND PAGE.![]()
![]()
(define (present-categories bml) (let* ((cat-list (map bookmark-category-of bml)) ;(cat-list-unique (remove-duplicates cat-list)) ;
) (map ;
(lambda (cat) (con (a-tag-target (string-append "bookmark-contents.html" "#" cat) cat "bookmark-main") (br)) ) (sort-list cat-list-unique (lambda (s t) (string<=? (downcase-string s) (downcase-string t)))))))
![]()
![]()
;; left-frame-page Write the left frame. (write-html '(raw) (html (head (title "Bookmark Categories")) (body (font-1 4 red (b "Bookmark categories")) (p) (present-categories bookmarks) (p) (font-1 1 red (when-generated)))) (in-startup-directory "bookmark-categories.html") ) ; -------------------------------------------------------------- ; THE RIGHT HAND PAGE.![]()
![]()
(define sentinel-bookmark (make-bookmark "" "" 'empty ""))![]()
![]()
(define (present-bookmarks bml) (let* ((sorted-bookmarks ;(sort-list bml (lambda (bm1 bm2) ;
(string<=? (downcase-string (bookmark-category-of bm1)) (downcase-string (bookmark-category-of bm2))))))) (present-bookmarks-1 sorted-bookmarks ;
(cons sentinel-bookmark (butlast sorted-bookmarks)) ;
) ) )
![]()
![]()
(define (present-bookmarks-1 bml prev-bml) (map2 (lambda (bm bm-prev) ;(if (not ;
(equal? (bookmark-category-of bm) (bookmark-category-of bm-prev))) (con (a-name (bookmark-category-of bm)) (h3 (bookmark-category-of bm)) (present-a-bookmark bm)) (present-a-bookmark bm))) bml prev-bml))
![]()
![]()
(define (present-a-bookmark bm) (let ((comment (bookmark-comment-of bm))) (con (a 'href (bookmark-url-of bm) 'title comment ;(bookmark-title-of-non-blank bm)) (br))))
![]()
![]()
;; right-frame-page Write the right frame. (write-html '(raw) (html (head (title "Bookmarks")) (body (font-1 6 red (b page-title)) (p) (present-bookmarks bookmarks) (vertical-space 25))) (in-startup-directory "bookmark-contents.html") )