;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Creating slides (nested switches) from the section structure of a document.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (make-slides)
  (apply-on-new-buffer-object
   (lambda (x) (sections->switch x '(section subsection subsubsection)))))

(define (make-slides-here)
  (apply-on-buffer-object
   (lambda (x) (sections->switch x '(section subsection subsubsection)))))

;;; Apply a procedure on a buffer's content.

(define (apply-on-buffer-object proc)
  ;; Apply @proc to the buffer content as scheme, and replace the buffer
  ;; content by the result of @proc.
  (let ((t (object->tree
	    (htmltm-unary-document
	     (proc (tree->object (the-buffer)))))))
    (tm-assign '() t)))

(define (apply-on-new-buffer-object proc)
  ;; Do as apply-on-buffer-object but create a new buffer, do not overwrite the
  ;; current buffer.
  (let ((t (object->tree
	    (htmltm-unary-document
	     (proc (tree->object (the-buffer)))))))
    (new-buffer)
    (tm-assign '() t)))

;;; Slide creation utilities

;; Depends: htmltm-list->document htmltm-serial htmltm-unary-document
;;          tmhtml-list-map

(define (sections->switch doc sections)
  (define (make-section title doc-items)
    (let ((doc2 (htmltm-list->document
		 (list-filter doc-items (lambda (x) (not (== x "")))))))
      (if (not title) doc2
	  (htmltm-serial (list title
			       (sections->switch doc2 (cdr sections)))))))
  (define (section? x)
    (func? x (car sections) 1))
  (htmltm-unary-document
   (if (null? sections) doc
       (make-switch-maybe
	(tmhtml-list-map make-section section? (cdr doc))
	0))))

(define (list-length<=1 l)
  (or (null? l) (null? (cdr l))))

(define (make-switch-maybe doclist pos)
  (if (list-length<=1 doclist)
      (htmltm-list->document doclist)
      (make-switch doclist pos)))

(define (make-switch doclist pos)
  `(hide_expand "switch" ,(list-ref doclist pos)
		(tuple ,@(list-assign doclist pos '(tmarker)))))

;;; List utilities

(define (list-split-at x i)
  ;; SRFI-1
  (let lp ((l x) (n i) (acc '()))
    (if (<= n 0)
      (values (reverse! acc) l)
      (lp (cdr l) (- n 1) (cons (car l) acc)))))

	     
(define (list-assign l i x)
  (receive (left right) (list-split-at l i)
    (append left (list x) (cdr right))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Deconstructing switches (flattening slides)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Not yet implemented

(define (flatten-switch)
  (switch-unselect-recursive)
  (apply-on-buffer-object flatten-switch-sub))

(define (switch-unselect-recursive)
  (go-innermost-switch)
  (switch-unselect-recursive-sub))

(define (switch-unselect-recursive-sub)
  (switch-unselect)
  (let ((oldp (the-path)))
    (go-outer-switch)
    (if (not (== (oldp (the-path))))
	(switch-unselect-recursive-sub))))

(define (flatten-switch-sub x)
  (postorder x flatten-switch-sub2))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Browsing slides
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Depends: safe-tree-ref search-in-tree-from

(define (next-slide)
  (go-innermost-switch)
  (next-slide-sub))

(define (prev-slide)
  (go-innermost-switch)
  (prev-slide-sub))

(define (next-slide-sub)  
  (if (< (switch-get-position) (switch-get-last))
      (begin
	(switch-to "next")
	(recursive-switch-to-sub "first"))
      (let ((oldp (the-path)))
	(go-outer-switch)
	(if (not (== (the-path) oldp))
	    (next-slide-sub)))))

(define (prev-slide-sub)
  (if (< 0 (switch-get-position))
      (begin
	(switch-to "previous")
	(recursive-switch-to-sub "last"))
      (let ((oldp (the-path)))
	(go-outer-switch)
	(if (not (== (the-path) oldp))
	    (prev-slide-sub)))))

(define (recursive-switch-to-sub where)
  (let ((oldp (the-path)))
    (go-inner-switch)
    (if (not (== (the-path) oldp))
	(begin
	  (switch-to where)
	  (recursive-switch-to-sub where)))))

;; Moving in the switch hierarchy

(define (go-innermost-switch)
  (let ((p (search-innermost-switch)))
    (if p
	(tm-go-to
	 (if (== (tree-get-label (subtree (the-buffer) p)) "document")
	     (append p '(0 0))
	     (rcons p 0))))))

(define (search-innermost-switch)
  (let rec ((t (the-buffer)) (p '()))
    (define (proc p2 t2)
      (let ((p3 (rec (safe-tree-ref t2 1) '())))
	(if p3 (append p2 '(1) p3) (rcons p2 1))))
    (search-in-tree-from t p "switch" proc)))

(define (go-outermost-switch)
  (let ((oldp (the-path)))
    (go-outer-switch)
    (if (not (== oldp (the-path)))
	(go-outermost-switch))))

(define (go-this-switch)
  (let ((p (search-upwards "switch")))
    (if (pair? p)
	(tm-go-to (append p '(1 0 0)))
	(tm-go-to '(0 0)))))

(define (go-outer-switch)
  (let ((p (search-upwards "switch")))
    (if (pair? p)
	(tm-go-to (append p '(0)))))
  (go-this-switch))

(define (go-inner-switch)
  (define (proc p t) p)
  (let ((old-p (the-path)))
    (go-this-switch)
    (let ((p1 (search-upwards "switch")))
      (let ((p2 (search-in-tree-from
		 (if (null? p1)
		     (the-buffer)
		     (subtree (the-buffer) (rcons p1 1)))
		 '() "switch" proc)))
	(if p2
	    (if (null? p1)
		(tm-go-to (append p2 '(1 0 0)))
		(tm-go-to (append p1 '(1) p2 '(1 0 0))))
	    (tm-go-to old-p))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Keymaps
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(kbd-map
  ("C-end" (next-slide))
  ("C-home" (prev-slide)))

(define (in-fold?)
  (or (inside? "fold")
      (inside? "unfold")))

(kbd-wildcards pre
  ("folded" "cmd f"))

(kbd-map in-fold?
  ("folded" "" "Fold command (f: fold, u: unfold)")
  ("folded f" (fold))
  ("folded u" (unfold)))