tec/org-mode
tec/org-mode
1
0
Fork 0
forked from mirrors/org-mode
Code Pull requests Releases Activity

org-drill: prevent errors caused by attempting to display inline images on a non-graphical display.

Browse source
This commit is contained in:
Paul Sexton 2012-05-05 08:09:22 +12:00
parent 6a38c1fac3
commit 5412883c1d
1 changed files with 176 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

253
contrib/lisp/org-drill.el
View file

@ -1,28 +1,28 @@
;; -*- coding: utf-8-unix -*- ;;; -*- coding: utf-8-unix -*-
;; org-drill.el - Self-testing using spaced repetition ;;; org-drill.el - Self-testing using spaced repetition
;; ;;;
;; Author: Paul Sexton <eeeickythump@gmail.com> ;;; Author: Paul Sexton <eeeickythump@gmail.com>
;; Version: 2.3.5 ;;; Version: 2.3.6
;; Repository at http://bitbucket.org/eeeickythump/org-drill/ ;;; Repository at http://bitbucket.org/eeeickythump/org-drill/
;; ;;;
;; This file is not part of GNU Emacs. ;;;
;; ;;; Synopsis
;; Synopsis ;;; ========
;; ======== ;;;
;; ;;; Uses the SuperMemo spaced repetition algorithms to conduct interactive
;; Uses the SuperMemo spaced repetition algorithms to conduct interactive ;;; "drill sessions", where the material to be remembered is presented to the
;; "drill sessions", where the material to be remembered is presented to the ;;; student in random order. The student rates his or her recall of each item,
;; student in random order. The student rates his or her recall of each item, ;;; and this information is used to schedule the item for later revision.
;; and this information is used to schedule the item for later revision. ;;;
;; ;;; Each drill session can be restricted to topics in the current buffer
;; Each drill session can be restricted to topics in the current buffer ;;; (default), one or several files, all agenda files, or a subtree. A single
;; (default), one or several files, all agenda files, or a subtree. A single ;;; topic can also be drilled.
;; topic can also be drilled. ;;;
;; ;;; Different "card types" can be defined, which present their information to
;; Different "card types" can be defined, which present their information to ;;; the student in different ways.
;; the student in different ways. ;;;
;; ;;; See the file README.org for more detailed documentation.
;; See the file README.org in the repository for more detailed documentation.
(eval-when-compile (require 'cl)) (eval-when-compile (require 'cl))
(eval-when-compile (require 'hi-lock)) (eval-when-compile (require 'hi-lock))
@ -37,6 +37,7 @@
:group 'org-link) :group 'org-link)
(defcustom org-drill-question-tag (defcustom org-drill-question-tag
"drill" "drill"
"Tag which topics must possess in order to be identified as review topics "Tag which topics must possess in order to be identified as review topics
@ -53,6 +54,7 @@ Nil means unlimited."
:type '(choice integer (const nil))) :type '(choice integer (const nil)))
(defcustom org-drill-maximum-duration (defcustom org-drill-maximum-duration
20 20
"Maximum duration of a drill session, in minutes. "Maximum duration of a drill session, in minutes.
@ -105,7 +107,7 @@ Possible values:
but a warning message is printed when each leech item is but a warning message is printed when each leech item is
presented." presented."
:group 'org-drill :group 'org-drill
:type '(choice (const warn) (const skip) (const nil))) :type '(choice (const 'warn) (const 'skip) (const nil)))
(defface org-drill-visible-cloze-face (defface org-drill-visible-cloze-face
@ -260,9 +262,9 @@ directory All files with the extension '.org' in the same
;; 'file-no-restriction' means current file/buffer, ignoring restrictions ;; 'file-no-restriction' means current file/buffer, ignoring restrictions
;; 'directory' means all *.org files in current directory ;; 'directory' means all *.org files in current directory
:group 'org-drill :group 'org-drill
:type '(choice (const file) (const tree) (const file-no-restriction) :type '(choice (const 'file) (const 'tree) (const 'file-no-restriction)
(const file-with-archives) (const agenda) (const 'file-with-archives) (const 'agenda)
(const agenda-with-archives) (const directory) (const 'agenda-with-archives) (const 'directory)
list)) list))
@ -288,7 +290,7 @@ Available choices are:
adjusting intervals when items are reviewed early or late has been taken adjusting intervals when items are reviewed early or late has been taken
from SM11, a later version of the algorithm, and included in Simple8." from SM11, a later version of the algorithm, and included in Simple8."
:group 'org-drill :group 'org-drill
:type '(choice (const sm2) (const sm5) (const simple8))) :type '(choice (const 'sm2) (const 'sm5) (const 'simple8)))
(defcustom org-drill-optimal-factor-matrix (defcustom org-drill-optimal-factor-matrix
@ -619,7 +621,7 @@ situation use `org-part-of-drill-entry-p'."
(defun org-drill-goto-entry (marker) (defun org-drill-goto-entry (marker)
(org-pop-to-buffer-same-window (marker-buffer marker)) (switch-to-buffer (marker-buffer marker))
(goto-char marker)) (goto-char marker))
@ -1507,18 +1509,38 @@ concealed by an overlay that displays the string TEXT."
(org-drill-unreplace-entry-text)))) (org-drill-unreplace-entry-text))))
(defun org-drill-replace-entry-text (text) (defmacro with-replaced-entry-text-multi (replacements &rest body)
"During the execution of BODY, the entire text of the current entry is
concealed by an overlay that displays the overlays in REPLACEMENTS."
`(progn
(org-drill-replace-entry-text ,replacements t)
(unwind-protect
(progn
,@body)
(org-drill-unreplace-entry-text))))
(defun org-drill-replace-entry-text (text &optional multi-p)
"Make an overlay that conceals the entire text of the item, not "Make an overlay that conceals the entire text of the item, not
including properties or the contents of subheadings. The overlay shows including properties or the contents of subheadings. The overlay shows
the string TEXT. the string TEXT.
If MULTI-P is non-nil, TEXT must be a list of values which are legal
for the `display' text property. The text of the item will be temporarily
replaced by all of these items, in the order in which they appear in
the list.
Note: does not actually alter the item." Note: does not actually alter the item."
(let ((ovl (make-overlay (point-min) (cond
(save-excursion ((and multi-p
(outline-next-heading) (listp text))
(point))))) (org-drill-replace-entry-text-multi text))
(overlay-put ovl 'category (t
'org-drill-replaced-text-overlay) (let ((ovl (make-overlay (point-min)
(overlay-put ovl 'display text))) (save-excursion
(outline-next-heading)
(point)))))
(overlay-put ovl 'category
'org-drill-replaced-text-overlay)
(overlay-put ovl 'display text)))))
(defun org-drill-unreplace-entry-text () (defun org-drill-unreplace-entry-text ()
@ -1528,6 +1550,27 @@ Note: does not actually alter the item."
(delete-overlay ovl))))) (delete-overlay ovl)))))
(defun org-drill-replace-entry-text-multi (replacements)
"Make overlays that conceal the entire text of the item, not
including properties or the contents of subheadings. The overlay shows
the string TEXT.
Note: does not actually alter the item."
(let ((ovl nil)
(p-min (point-min))
(p-max (save-excursion
(outline-next-heading)
(point))))
(assert (>= (- p-max p-min) (length replacements)))
(dotimes (i (length replacements))
(setq ovl (make-overlay (+ p-min (* 2 i))
(if (= i (1- (length replacements)))
p-max
(+ p-min (* 2 i) 1))))
(overlay-put ovl 'category
'org-drill-replaced-text-overlay)
(overlay-put ovl 'display (nth i replacements)))))
(defmacro with-replaced-entry-heading (heading &rest body) (defmacro with-replaced-entry-heading (heading &rest body)
`(progn `(progn
(org-drill-replace-entry-heading ,heading) (org-drill-replace-entry-heading ,heading)
@ -1577,7 +1620,8 @@ Note: does not actually alter the item."
(with-hidden-cloze-hints (with-hidden-cloze-hints
(with-hidden-cloze-text (with-hidden-cloze-text
(org-drill-hide-all-subheadings-except nil) (org-drill-hide-all-subheadings-except nil)
(org-display-inline-images t) (ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all) (org-cycle-hide-drawers 'all)
(prog1 (org-drill-presentation-prompt) (prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p)))))) (org-drill-hide-subheadings-if 'org-drill-entry-p))))))
@ -1586,6 +1630,8 @@ Note: does not actually alter the item."
(defun org-drill-present-default-answer (reschedule-fn) (defun org-drill-present-default-answer (reschedule-fn)
(org-drill-hide-subheadings-if 'org-drill-entry-p) (org-drill-hide-subheadings-if 'org-drill-entry-p)
(org-drill-unhide-clozed-text) (org-drill-unhide-clozed-text)
(ignore-errors
(org-display-inline-images t))
(with-hidden-cloze-hints (with-hidden-cloze-hints
(funcall reschedule-fn))) (funcall reschedule-fn)))
@ -1600,7 +1646,8 @@ Note: does not actually alter the item."
(goto-char (nth (random* (min 2 (length drill-sections))) (goto-char (nth (random* (min 2 (length drill-sections)))
drill-sections)) drill-sections))
(org-show-subtree))) (org-show-subtree)))
(org-display-inline-images t) (ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all) (org-cycle-hide-drawers 'all)
(prog1 (org-drill-presentation-prompt) (prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p))))))) (org-drill-hide-subheadings-if 'org-drill-entry-p)))))))
@ -1616,7 +1663,8 @@ Note: does not actually alter the item."
(save-excursion (save-excursion
(goto-char (nth (random* (length drill-sections)) drill-sections)) (goto-char (nth (random* (length drill-sections)) drill-sections))
(org-show-subtree))) (org-show-subtree)))
(org-display-inline-images t) (ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all) (org-cycle-hide-drawers 'all)
(prog1 (org-drill-presentation-prompt) (prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p))))))) (org-drill-hide-subheadings-if 'org-drill-entry-p)))))))
@ -1694,7 +1742,8 @@ items if FORCE-SHOW-FIRST or FORCE-SHOW-LAST is non-nil)."
;; while (org-pos-in-regexp (match-beginning 0) ;; while (org-pos-in-regexp (match-beginning 0)
;; org-bracket-link-regexp 1)) ;; org-bracket-link-regexp 1))
;; (org-drill-hide-matched-cloze-text))))) ;; (org-drill-hide-matched-cloze-text)))))
(org-display-inline-images t) (ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all) (org-cycle-hide-drawers 'all)
(prog1 (org-drill-presentation-prompt) (prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p) (org-drill-hide-subheadings-if 'org-drill-entry-p)
@ -1741,7 +1790,8 @@ the second to last, etc."
(incf cnt) (incf cnt)
(if (= cnt to-hide) (if (= cnt to-hide)
(org-drill-hide-matched-cloze-text))))))) (org-drill-hide-matched-cloze-text)))))))
(org-display-inline-images t) (ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all) (org-cycle-hide-drawers 'all)
(prog1 (org-drill-presentation-prompt) (prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p) (org-drill-hide-subheadings-if 'org-drill-entry-p)
@ -1905,6 +1955,23 @@ pieces rather than one."
question question
(org-drill-hide-all-subheadings-except nil) (org-drill-hide-all-subheadings-except nil)
(org-cycle-hide-drawers 'all) (org-cycle-hide-drawers 'all)
(ignore-errors
(org-display-inline-images t))
(prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p)))))
(defun org-drill-present-card-using-multiple-overlays (replacements &optional answer)
"TEXTS is a list of valid values for the 'display' text property.
Present these overlays, in sequence, as the only
visible content of the card."
(with-hidden-comments
(with-replaced-entry-text-multi
replacements
(org-drill-hide-all-subheadings-except nil)
(org-cycle-hide-drawers 'all)
(ignore-errors
(org-display-inline-images t))
(prog1 (org-drill-presentation-prompt) (prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p))))) (org-drill-hide-subheadings-if 'org-drill-entry-p)))))
@ -2356,12 +2423,12 @@ than starting a new one."
(org-map-drill-entries (org-map-drill-entries
(lambda () (lambda ()
(org-drill-progress-message (org-drill-progress-message
(+ (length *org-drill-new-entries*) (+ (length *org-drill-new-entries*)
(length *org-drill-overdue-entries*) (length *org-drill-overdue-entries*)
(length *org-drill-young-mature-entries*) (length *org-drill-young-mature-entries*)
(length *org-drill-old-mature-entries*) (length *org-drill-old-mature-entries*)
(length *org-drill-failed-entries*)) (length *org-drill-failed-entries*))
(incf cnt)) (incf cnt))
(cond (cond
((not (org-drill-entry-p)) ((not (org-drill-entry-p))
nil) ; skip nil) ; skip
@ -2448,7 +2515,9 @@ than starting a new one."
(cond (cond
(end-pos (end-pos
(when (markerp end-pos) (when (markerp end-pos)
(org-drill-goto-entry end-pos)) (org-drill-goto-entry end-pos)
(org-reveal)
(org-show-entry))
(let ((keystr (command-keybinding-to-string 'org-drill-resume))) (let ((keystr (command-keybinding-to-string 'org-drill-resume)))
(message (message
"You can continue the drill session with the command `org-drill-resume'.%s" "You can continue the drill session with the command `org-drill-resume'.%s"
@ -2600,7 +2669,7 @@ the tag 'imported'."
(unless path (unless path
(setq path (org-get-outline-path))) (setq path (org-get-outline-path)))
(org-copy-subtree) (org-copy-subtree)
(org-pop-to-buffer-same-window dest) (switch-to-buffer dest)
(setq m (setq m
(condition-case nil (condition-case nil
(org-find-olp path t) (org-find-olp path t)
@ -2682,7 +2751,7 @@ copy them across."
scheduled-time (org-get-scheduled-time (point))) scheduled-time (org-get-scheduled-time (point)))
(save-excursion (save-excursion
;; go to matching entry in destination buffer ;; go to matching entry in destination buffer
(org-pop-to-buffer-same-window (marker-buffer marker)) (switch-to-buffer (marker-buffer marker))
(goto-char marker) (goto-char marker)
(org-drill-strip-entry-data) (org-drill-strip-entry-data)
(unless (zerop total-repeats) (unless (zerop total-repeats)
@ -2738,7 +2807,14 @@ copy them across."
("imperfect" "darkturquoise") ("imperfect" "darkturquoise")
("present perfect" "royalblue") ("present perfect" "royalblue")
;; future tenses ;; future tenses
("future" "green")) ("future" "green")
;; moods (backgrounds).
("indicative" nil) ; default
("subjunctive" "medium blue")
("conditional" "grey30")
("negative imperative" "red4")
("positive imperative" "darkgreen")
)
"Alist where each entry has the form (TENSE COLOUR), where "Alist where each entry has the form (TENSE COLOUR), where
TENSE is a string naming a tense in which verbs can be TENSE is a string naming a tense in which verbs can be
conjugated, and COLOUR is a string specifying a foreground colour conjugated, and COLOUR is a string specifying a foreground colour
@ -2754,50 +2830,72 @@ the name of the tense.")
(inf-hint (org-entry-get (point) "VERB_INFINITIVE_HINT" t)) (inf-hint (org-entry-get (point) "VERB_INFINITIVE_HINT" t))
(translation (org-entry-get (point) "VERB_TRANSLATION" t)) (translation (org-entry-get (point) "VERB_TRANSLATION" t))
(tense (org-entry-get (point) "VERB_TENSE" nil)) (tense (org-entry-get (point) "VERB_TENSE" nil))
(mood (org-entry-get (point) "VERB_MOOD" nil))
(highlight-face nil)) (highlight-face nil))
(unless (and infinitive translation tense) (unless (and infinitive translation (or tense mood))
(error "Missing information for verb conjugation card (%s, %s, %s) at %s" (error "Missing information for verb conjugation card (%s, %s, %s, %s) at %s"
infinitive translation tense (point))) infinitive translation tense mood (point)))
(setq tense (downcase (car (read-from-string tense))) (setq tense (if tense (downcase (car (read-from-string tense))))
mood (if mood (downcase (car (read-from-string mood))))
infinitive (car (read-from-string infinitive)) infinitive (car (read-from-string infinitive))
inf-hint (if inf-hint (car (read-from-string inf-hint))) inf-hint (if inf-hint (car (read-from-string inf-hint)))
translation (car (read-from-string translation))) translation (car (read-from-string translation)))
(setq highlight-face (setq highlight-face
(list :foreground (list :foreground
(or (second (assoc-string tense org-drill-verb-tense-alist t)) (or (second (assoc-string tense org-drill-verb-tense-alist t))
"red"))) "hotpink")
:background
(second (assoc-string mood org-drill-verb-tense-alist t))))
(setq infinitive (propertize infinitive 'face highlight-face)) (setq infinitive (propertize infinitive 'face highlight-face))
(setq translation (propertize translation 'face highlight-face)) (setq translation (propertize translation 'face highlight-face))
(setq tense (propertize tense 'face highlight-face)) (if tense (setq tense (propertize tense 'face highlight-face)))
(list infinitive inf-hint translation tense))) (if mood (setq mood (propertize mood 'face highlight-face)))
(list infinitive inf-hint translation tense mood)))
(defun org-drill-present-verb-conjugation () (defun org-drill-present-verb-conjugation ()
"Present a drill entry whose card type is 'conjugate'." "Present a drill entry whose card type is 'conjugate'."
(destructuring-bind (infinitive inf-hint translation tense) (flet ((tense-and-mood-to-string
(org-drill-get-verb-conjugation-info) (tense mood)
(org-drill-present-card-using-text (cond
(cond ((and tense mood)
((zerop (random* 2)) (format "%s tense, %s mood" tense mood))
(format "\nTranslate the verb\n\n%s\n\nand conjugate for the %s tense.\n\n" (tense
infinitive tense)) (format "%s tense" tense))
(t (mood
(format "\nGive the verb that means\n\n%s %s\n (format "%s mood" mood)))))
and conjugate for the %s tense.\n\n" (destructuring-bind (infinitive inf-hint translation tense mood)
translation (org-drill-get-verb-conjugation-info)
(if inf-hint (format " [HINT: %s]" inf-hint) "") (org-drill-present-card-using-text
tense)))))) (cond
((zerop (random* 2))
(format "\nTranslate the verb\n\n%s\n\nand conjugate for the %s.\n\n"
infinitive (tense-and-mood-to-string tense mood)))
(t
(format "\nGive the verb that means\n\n%s %s\n
and conjugate for the %s.\n\n"
translation
(if inf-hint (format " [HINT: %s]" inf-hint) "")
(tense-and-mood-to-string tense mood))))))))
(defun org-drill-show-answer-verb-conjugation (reschedule-fn) (defun org-drill-show-answer-verb-conjugation (reschedule-fn)
"Show the answer for a drill item whose card type is 'conjugate'. "Show the answer for a drill item whose card type is 'conjugate'.
RESCHEDULE-FN must be a function that calls `org-drill-reschedule' and RESCHEDULE-FN must be a function that calls `org-drill-reschedule' and
returns its return value." returns its return value."
(destructuring-bind (infinitive inf-hint translation tense) (destructuring-bind (infinitive inf-hint translation tense mood)
(org-drill-get-verb-conjugation-info) (org-drill-get-verb-conjugation-info)
(with-replaced-entry-heading (with-replaced-entry-heading
(format "%s tense of %s ==> %s\n\n" (format "%s of %s ==> %s\n\n"
(capitalize tense) (capitalize
(cond
((and tense mood)
(format "%s tense, %s mood" tense mood))
(tense
(format "%s tense" tense))
(mood
(format "%s mood" mood))))
infinitive translation) infinitive translation)
(funcall reschedule-fn)))) (funcall reschedule-fn))))
@ -2915,3 +3013,4 @@ returns its return value."
(provide 'org-drill) (provide 'org-drill)