;;; speed-reader-mode.el --- Speed reading mode

;; Copyright (C) 2006 Ben Hyde

;; Author: Ben Hyde <bhyde@pobox.com>
;; Maintainer: Ben Hyde
;; Keywords: reading, frf, dyslexia, speed-reading, rsvp


;; Comentary:

;; Instructions

;; Load this into your your xemacs, invoke M-x sr, in a buffer
;; you wish to read.  The text in the buffer will largely disappear
;; with the exception of a window showing a few words begining at
;; the current point.  This window with proceed to sweep across
;; the buffer text.  This simulates how presumably your attention
;; is focused during traditional reading.  By masking out the test
;; your not currently reading it helps to keep you focused.

;; While this technique is analagous to techniques used in some approaches
;; to speed reading.  This technique is based on a therapy describe
;; here[1] designed to help dyslexics improve their skill at focusing
;; their visual field.  

;; [1] http://cbcl.mit.edu/projects/cbcl/people/geiger/memo_complete.pdf


;;; Customization

(defgroup sr nil
  "Focus Reading Frame Mode"
  :prefix "sr-"
  :group 'wp)

(defcustom sr-window-size 35
  "*Minimum number of characters revealed in the attention window."
  :type 'integer
  :group 'sr)

(defcustom sr-words-per-minute 150
  "*Number of words per minute to sweep the attention window thru."
  :type 'integer
  :group 'sr)

(defcustom sr-initial-pause 1.0
  "*How many seconds to pause so your eyes can focus when starting."
  :type 'float
  :group 'sr)

(defcustom sr-focus-face-name 'sr-attention-face
  "*Face to use in the region where out attetion is focused."
  :type 'face
  :group 'sr)

(defcustom sr-mask-face-name 'sr-mask-face
  "*Face to mask out everything else."
  :type 'face
  :group 'sr)

(defcustom sr-pause-mask-face-name 'sr-pause-mask-face
  "*Face for the mask when we are paused."
  :type 'face
  :group 'sr)

(defcustom sr-word-length 5
  "*Estimated characters per word."
  :type 'integer
  :group 'sr)

(defcustom sr-show-whole-words nil
  "*Resize attention window as we run to show entire words"
  :type 'boolean
  :group 'sr)

(defcustom sr-show-viewer nil
  "*Toggle controling the display of a seperate viewer"
  :type 'boolean
  :group 'sr)

(defcustom sr-viewer-face-name 'sr-viewer-face
  "*Face used in the seperate viewer"
  :type 'face
  :group 'sr)


;;;; Faces

(defface sr-attention-face '((((type x pm mswindows)
				(class color grayscale)
				(background light))
			       (:foreground "black"))
			      (((type x pm mswindows)
				(class color grayscale)
				(background dark))
			       (:foreground "black"))
			      (((type tty)
				(class color)
				(background dark))
			       (:foreground "black"
					    :dim t))
			      (((type tty)
				(class color)
				(background light))
			       (:foreground "black")))
  "Face used for the masked out text."
  :group 'sr)

(defface sr-mask-face '((((type x pm mswindows)
			   (class color grayscale)
			   (background light))
			  (:foreground "lightgray"))
			 (((type x pm mswindows)
			   (class color grayscale)
			   (background dark))
			  (:foreground "lightgray"))
			 (((type tty)
			   (class color)
			   (background dark))
			  (:foreground "lightgray"
				       :dim t))
			 (((type tty)
			   (class color)
			   (background light))
			  (:foreground "lightgray")))
  "Face used for the masked out text."
  :group 'sr)

(defface sr-pause-mask-face '((((type x pm mswindows)
			   (class color grayscale)
			   (background light))
			  (:foreground "firebrick"))
			 (((type x pm mswindows)
			   (class color grayscale)
			   (background dark))
			  (:foreground "firebrick"))
			 (((type tty)
			   (class color)
			   (background dark))
			  (:foreground "firebrick"
				       :dim t))
			 (((type tty)
			   (class color)
			   (background light))
			  (:foreground "firebrick")))
  "Face used for the masked out text, when we are paused."
  :group 'sr)


(defface sr-viewer-face '((((type x pm mswindows)
			   (class color grayscale)
			   (background light))
			  (:foreground "blue" :family "helvetica" :size 20))
			 (((type x pm mswindows)
			   (class color grayscale)
			   (background dark))
			  (:foreground "red" :family "helvetica" :size 20))
			 (((type tty)
			   (class color)
			   (background dark))
			  (:foreground "green" :dim t))
			 (((type tty)
			   (class color)
			   (background light))
			  (:foreground "pink")))
  "Face used in the seperate viewer."
  :group 'sr)

;;;; Internal state

(defvar sr-read-point nil)

(defvar sr-background-extent nil) 

(defvar sr-attention-extent nil)

(defvar sr-viewer-extent nil) 

(defvar sr-itimer nil)

(defvar sr-saved-window-configuration nil)



;;;; Infrastructure

(defun sr-interval ()
  (/ 1 (/ (* sr-word-length sr-words-per-minute) 60.0)))

(defvar sr-viewer-name " *Speed Reader Viewer*")

(defun sr-get-or-make-viewer ()
  (or (get-buffer sr-viewer-name)
      (with-current-buffer (get-buffer-create sr-viewer-name)
	(setf sr-viewer-extent (make-extent (point-min) (point-max)))
	(set-extent-face sr-viewer-extent sr-viewer-face-name)
	(current-buffer))))

(defun sr-update-viewer (extent)
  (when sr-show-viewer
    (let* ((viewer (sr-get-or-make-viewer))
	   (viewer-name (buffer-name viewer)))
      (with-output-to-temp-buffer viewer-name
	(with-current-buffer (get-buffer viewer-name)
	  (let ((end (point-max)))
	    (goto-char end)
	    (insert-buffer-substring (extent-object extent)
				     (extent-start-position extent)
				     (extent-end-position extent))
	    (setf (extent-end-position sr-viewer-extent) (point-max))
	    (delete-region (point-min) end)
	    (goto-char (point-min))
	    (replace-string "
" " " nil)
	  ))))))

(defun sr-make-extents ()
  (setf sr-attention-extent
	(let ((extent (make-extent (point-marker) (point-marker))))
	  (set-extent-property extent 'id 'sr-attention)
	  (set-extent-priority extent 10) ; ? try to highlighting
	  (set-extent-face extent sr-focus-face-name)
	  (sr-size-extent extent)))
  (setf sr-background-extent
	(let ((extent (make-extent (point-min) (point-max))))
	  (set-extent-property extent 'id 'sr-background)
	  (set-extent-priority extent 10) ; ? try to highlighting
	  (set-extent-face extent sr-mask-face-name)
	  extent)))

(defun sr-get-or-make-itimer ()
  (unless sr-itimer
    (setf sr-itimer (make-itimer))
;    (setf (itimer-name sr-itimer) "SR stepper")
    (set-itimer-restart sr-itimer (sr-interval))
    (set-itimer-function  sr-itimer 'sr-advance))
  sr-itimer)

(defun sr-size-extent (extent)
  (save-excursion
    (goto-char sr-read-point)
    (when sr-show-whole-words
      (forward-word 1)
      (forward-word -1))
    (setf (extent-start-position extent) (point))
    (forward-char sr-window-size)
    (when sr-show-whole-words
      (forward-word 1))
    (setf (extent-end-position extent) (point-marker)))
  (sr-update-viewer extent)
  extent)

(defun sr-advance ()
  (interactive)
  (with-current-buffer (extent-object sr-attention-extent)
    (cond
     ((= (point-max) (extent-end-position sr-attention-extent))
      (sr-done))
     (t
      (incf sr-read-point)
      (sr-size-extent sr-attention-extent)
      (set-itimer-restart sr-itimer (sr-interval))
      (sr-scroll-if-necessary)))))

(defun sr-scroll-if-necessary () ;; TBD More work needed
  (unless (pos-visible-in-window-p (extent-end-position sr-attention-extent)
				   (selected-window))
    (goto-char (extent-start-position sr-attention-extent))
    (beginning-of-line)
    (set-window-start (selected-window)
		      (extent-start-position sr-attention-extent)) t))

(defvar sr-mode-map
  (let ((map (make-keymap)))
    (set-keymap-name map 'sr-mode-map)

    ;; Bind all printing characters to `sr-quit'.
    (let ((i 32)
	  (str (make-string 1 0)))
      (while (< i 127)
	(aset str 0 i)
	(define-key map str 'sr-quit)
	(setq i (1+ i))))

    ;; Speed Control
    (define-key map "a" 'sr-backup)
    (define-key map "f" 'sr-faster)
    (define-key map "d" 'sr-go-or-pause)
    (define-key map "s" 'sr-slower)


    ;; Help
    (define-key map '(control h) 'sr-help)
    (define-key map 'f1 'sr-help)
    (define-key map 'help 'sr-help)

    map)
  "Keymap for sr-mode.")


;;;; User Interface
  
(defun speed-reader ()
  (interactive)
  (sr))

(defun sr ()
  (interactive)
  (sr-mode)
  (display-message 'command "Enter SR mode: s/d/f/h = slower/pause/faster/help, otherkeys exit"))

(defun sr-quit ()
  (interactive)
  (sr-done)
  (display-message 'command "Exit SR mode"))

(defun sr-adjust-interval (description num dom)
  (setf sr-words-per-minute (/ (* num sr-words-per-minute) dom))
  (set-itimer-restart sr-itimer (sr-interval))
  (display-message 'command
    (format "SR: %s %d cpm"
	    description sr-words-per-minute)))

(defun sr-faster () 
  (interactive)
  (sr-adjust-interval 'faster 110 100))

(defun sr-backup ()
  (interactive)
  (decf sr-read-point sr-window-size)
  ; (set-itimer-value sr-itimer sr-initial-pause) ;; ?
  (sr-size-extent sr-attention-extent))

(defun sr-go-or-pause ()
  (interactive)
  (display-message 
      'command
    (cond
     ((itimer-live-p sr-itimer)
      (delete-itimer sr-itimer)
      (setf (extent-face sr-background-extent) sr-pause-mask-face-name)
      "sr: paused")
     (t
      (setf (extent-face sr-background-extent) sr-mask-face-name)
      (activate-itimer sr-itimer)
      "sr: resume"))))

(defun sr-slower ()
  (interactive)
  (sr-adjust-interval 'slower 100 110))

(defun sr-help () 
  (interactive)
  (display-message 'command "tbd - sr-help"))

(defun sr-mode ()
  "Start sr minor mode.

\\{sr-mode-map}"

  (setf sr-saved-window-configuration (current-window-configuration))
  (setf sr-read-point (point))
  (sr-make-extents)
  (sr-get-or-make-itimer)
  (set-itimer-value sr-itimer (or sr-initial-pause
				   (sr-interval)))
  (activate-itimer sr-itimer)
  (setq sr-mode (gettext " SR")
	overriding-local-map sr-mode-map)
  (redraw-modeline)
;  (run-hooks 'sr-mode-hook)
  t)

(defun sr-done ()
  (interactive)
  (setq overriding-local-map nil
	sr-mode nil)
  (redraw-modeline)
  (let ((itimer? (shiftf sr-itimer nil)))
    (when itimer?
      (delete-itimer itimer?)))
  (let ((extent? (shiftf sr-attention-extent nil)))
    (when extent?
      (delete-extent extent?)))
  (let ((extent? (shiftf sr-background-extent nil)))
    (when extent?
      (delete-extent extent?)))
  (shiftf (current-window-configuration) sr-saved-window-configuration nil)
;  (run-hooks 'sr-mode-end-hook)
  )