Xref: utzoo gnu.emacs:1242 comp.emacs:6492 alt.sex:700
Path: utzoo!utgpu!jarvis.csri.toronto.edu!rutgers!aramis.rutgers.edu!athos.rutgers.edu!mende
From: mende@athos.rutgers.edu (Bob Mende)
Newsgroups: gnu.emacs,comp.emacs,alt.sex
Subject: purity.el (part 1)
Message-ID: <Jul.17.23.59.43.1989.20914@athos.rutgers.edu>
Date: 18 Jul 89 04:00:08 GMT
Organization: Rutgers Univ., New Brunswick, N.J.
Lines: 603

Since I have had over 100 requests for this, I am posting it.... enjoy.
please replace the following three characters

<DEL> with a real delete
<CTRL-C> with a real ctrl-c
<CTRL-S> with a real ctrl-s

;;
;;  Purity.el    Emacs lisp program to administer the purity test.
;;               Robert Mende (mende@aramis.rutgers.edu)
;;               5/5/89
;;
;; This file is not offically part of GNU Emacs, but can be if FSF wishes
;; it to be so.  Distributed under the GNU copyleft.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

(setq purity-test-extra-buffer "*Hit Space Bar To Continue*")

(defvar purity-test-save-file
  (concat (getenv "HOME") "/.purity-test.save.el")
  "*file to save purity test saves in")

(defvar purity-test-mode-map (make-sparse-keymap)
  "the keymap used while adminstering the purity test")

(defconst purity-test-backup-size 20
  "*Number of questions that can be backed up")

(defun purity-test-hold-question (question answer section section-text)
  (cond ((>= (length purity-test-backup-ring) 
	    purity-test-backup-size)
	 (setcdr (nthcdr (- purity-test-backup-size 2)
			 purity-test-backup-ring)
		 nil)))
  (setq purity-test-backup-ring (cons (list question answer 
					    section section-text)
				      purity-test-backup-ring))
  purity-test-backup-ring)

(defun purity-test-backup ()
  "Backup up one question (or many times)"
;; this is fun!!!  (pseudo code)
;pop off first element
;is it in the same section
;    yes:
;	cons question onto section-questions
;    no:
;	cons section-text then section name to section question
;	then cons section question onto questions
;	then make a install new section name/text
;	create new section-questions with this question
;was this a yes answer
;    yes:
;	subtract one from the score
;call next question
;;
  (interactive)
  (cond 
   ((not (consp purity-test-backup-ring))
    (message "No more backup information available")
    (ding)
    (sit-for 1))
   (t
    (let ((question-text (car (car purity-test-backup-ring)))
	  (question-answer (car (cdr (car purity-test-backup-ring))))
	  (section-name (car (cdr (cdr (car purity-test-backup-ring)))))
	  (section-text (car (cdr (cdr (cdr (car purity-test-backup-ring)))))))
      (setq purity-test-backup-ring (cdr purity-test-backup-ring))
      (setq purity-test-section-questions
	    (cons purity-test-questions-text purity-test-section-questions))
      (cond 
       ((string-equal section-name purity-test-section-name)
	(setq purity-test-section-questions 
	      (cons question-text purity-test-section-questions)))
       (t
	(message (concat "backing into " section-name "."))
	(sit-for 1)
	(message "")
	(setq purity-test-section-questions 
	      (cons purity-test-section-text purity-test-section-questions))
	(setq purity-test-section-questions 
	      (cons purity-test-section-name purity-test-section-questions))
	(setq purity-test-questions
	      (cons purity-test-section-questions purity-test-questions))
	(setq purity-test-section (1- purity-test-section))
	(setq purity-test-section-name section-name)
	(setq purity-test-section-text section-text)
	(setq purity-test-section-questions 
	      (list question-text))))
      (setq purity-test-question (- purity-test-question 2))
      (setq purity-test-question-text (prin1-to-string purity-test-question))
      (cond (question-answer
	     (setq purity-test-score (1- purity-test-score))))
      (purity-test-next-question)))))

(defun purity-test-yes ()
  "I have done this"
  (interactive)
  (setq purity-test-score (1+ purity-test-score))
  (purity-test-hold-question purity-test-questions-text
			     t
			     purity-test-section-name
			     purity-test-section-text)
  (purity-test-next-question))

(defun purity-test-no ()
  "I have not done this"
  (interactive)
  (purity-test-hold-question purity-test-questions-text
			     nil
			     purity-test-section-name
			     purity-test-section-text)
  (purity-test-next-question))

(defun purity-test-display (header question)
  (setq buffer-read-only nil)
  (erase-buffer)
  (goto-char 0)
  (if (not (null header))
      (insert header "

"))
  (insert question)
  (goto-char 0)
  (setq buffer-read-only t))

(defun purity-test-pop-up (header question)
  (save-excursion
    (save-restriction
      (switch-to-buffer (get-buffer-create purity-test-extra-buffer))
      (purity-test-display header question)
      (view-buffer purity-test-extra-buffer)
      (setq buffer-read-only nil)
      (erase-buffer)
      (setq buffer-read-only t)
      (discard-input))))

(defun purity-test-next-question ()
  (setq purity-test-question (1+ purity-test-question))
  (setq purity-test-question-text (prin1-to-string purity-test-question))
  (cond ((and (null purity-test-section-questions)
	      (null purity-test-questions))
	 (setq purity-test-question (1- purity-test-question))
	 (setq purity-test-question-text (prin1-to-string purity-test-question))
	 (purity-test-display-score)
	 (purity-test-done))
	(t
	 (cond ((null purity-test-section-questions)
		(setq purity-test-section (1+ purity-test-section))
		(setq purity-test-section-questions (car purity-test-questions))
		(setq purity-test-section-name (car purity-test-section-questions))
		(setq purity-test-section-questions (cdr purity-test-section-questions))
		(setq purity-test-section-text (car purity-test-section-questions))
		(setq purity-test-section-questions (cdr purity-test-section-questions))
		(setq purity-test-questions (cdr purity-test-questions))
		(purity-test-describe-section)
		(discard-input)))
	 (setq purity-test-questions-text (car purity-test-section-questions))

	 (purity-test-display "Have you ever:" purity-test-questions-text)
	 (setq purity-test-section-questions (cdr purity-test-section-questions)))))

(defun purity-test-describe-section ()
  (interactive)
  (purity-test-pop-up (concat "Section "
			      (prin1-to-string purity-test-section)
			      "    "
			      purity-test-section-name)
		      purity-test-section-text))


(defun purity-test-quit ()
  "quit purity test with option to save"
  (interactive)
  (cond ((y-or-n-p "Are you sure you want to quit the purity test? ")
	 (cond ((y-or-n-p "Save current status of test? ")
		(purity-test-save)))
	 (setq purity-test-question (1- purity-test-question))
	 (setq purity-test-question-text (prin1-to-string purity-test-question))
	 (purity-test-display-score)
	 (purity-test-done)))
  (message ""))

(defun purity-test-done ()
  (fundamental-mode)
  (setq buffer-read-only t)
  (kill-buffer purity-test-extra-buffer))

(defun purity-test-current-score ()
  (interactive)
  (save-excursion
    (save-restriction
      (setq purity-test-question (1- purity-test-question))
      (setq purity-test-question-text (prin1-to-string purity-test-question))
      (switch-to-buffer (get-buffer-create purity-test-extra-buffer))
      (purity-test-display-score)
      (view-buffer purity-test-extra-buffer)
      (setq buffer-read-only nil)
      (erase-buffer)
      (setq buffer-read-only t)
      (setq purity-test-question (1+ purity-test-question))
      (setq purity-test-question-text (prin1-to-string purity-test-question))
      (discard-input))))

(defun purity-test-display-score ()
  (setq buffer-read-only nil)
  (erase-buffer)
  (goto-char 0)
  (insert "You answered yes to ")
  (insert (prin1-to-string purity-test-score))
  (insert " questions out of ")
  (insert purity-test-question-text)
  (insert".

This is a score of: ")
  (cond ((zerop purity-test-question)
	 (insert "---"))
	((= purity-test-score purity-test-question)
	 (insert "0%"))
	(t
	 (insert (prin1-to-string (/ (* (- purity-test-question
					   purity-test-score)
					10000)
				     purity-test-question)))
	 (backward-char 2)
	 (insert ".")
	 (forward-char 2)
	 (insert "%")))
  (goto-char 0)
  (setq buffer-read-only t))

(defun purity-test-save ()
  "Save current status for taking purity test onto disk."
  (interactive)
  (set-buffer (create-file-buffer purity-test-save-file))
  (erase-buffer)
  (insert "(setq purity-test-SAVE-versionID \"" 
	  purity-test-versionID
	  "\")
")
  (insert "(setq purity-test-SAVE-question "
	  purity-test-question-text
	  ")
")
  (insert "(setq purity-test-SAVE-score "
	  (prin1-to-string purity-test-score)
	  ")
")
  (cond ((file-exists-p purity-test-save-file)
	 (set-file-modes purity-test-save-file 128)
	 (delete-file purity-test-save-file)))
  (write-file purity-test-save-file)
  (set-file-modes purity-test-save-file 256) ;; -r--------
  (kill-buffer (buffer-name))
  (set-buffer "*Purity Test*"))

(defun purity-test-restore ()
  "restore a saved purity test session"
  (interactive)
  (cond ((not (file-exists-p purity-test-save-file))
	 (purity-test-pop-up "Error restoring save file"
			     (concat purity-test-save-file
				     " not found.")))
	(t
	 (load-file purity-test-save-file)
	 (cond ((not (string-equal purity-test-versionID
				   purity-test-SAVE-versionID))
		(purity-test-pop-up "Error restoring save file"
				    (concat "The saved file is for questions identified as \""
					    purity-test-SAVE-versionID
					    "\"
while the questions of this test are \""
					    purity-test-versionID
					    ".")))
	       (t
		(message "restoring ... ")
		(cond ((purity-test-skip-to purity-test-SAVE-question)
		       (setq purity-test-question (1- purity-test-question))
		       (setq purity-test-question-text (prin1-to-string purity-test-question))
		       (setq purity-test-score purity-test-SAVE-score)
		       (set-file-modes purity-test-save-file 128)
		       (delete-file purity-test-save-file)
		       (message "restoring ... done")
		       (purity-test-next-question))
		      (t
		       (purity-test-pop-up "Error restoring save file"
					   (concat "Could not skip to question "
						   (prin1-to-sting purity-test-SAVE-question))))))))))
		       

(defun purity-test-skip-to (question-goal)
  (let ((purity-test-R-section 0)
	(purity-test-R-section-name "")
	(purity-test-R-section-text "")
	(purity-test-R-section-questions ())
	(purity-test-R-question 1)
	(purity-test-R-questions-text "")
	(purity-test-R-questions (cdr (purity-test-init-questions)))
	(cant-find nil))
    (while (and (< purity-test-R-question question-goal)
		(not cant-find))
      (setq purity-test-R-question (1+ purity-test-R-question))
      (cond ((and (null purity-test-R-section-questions)
		  (null purity-test-R-questions))
	     (setq cant-find t))
	    (t
	     (cond ((null purity-test-R-section-questions)
		    (setq purity-test-R-section (1+ purity-test-R-section))
		    (setq purity-test-R-section-questions (car purity-test-R-questions))
		    (setq purity-test-R-section-name (car purity-test-R-section-questions))
		    (setq purity-test-R-section-questions (cdr purity-test-R-section-questions))
		    (setq purity-test-R-section-text (car purity-test-R-section-questions))
		    (setq purity-test-R-section-questions (cdr purity-test-R-section-questions))
		    (setq purity-test-R-questions (cdr purity-test-R-questions))))))
      (setq purity-test-R-questions-text (car purity-test-R-section-questions))
      (setq purity-test-R-section-questions (cdr purity-test-R-section-questions)))
    (cond (cant-find
	   nil)
	  (t
	   (setq purity-test-section purity-test-R-section)
	   (setq purity-test-section-name purity-test-R-section-name)
	   (setq purity-test-section-text purity-test-R-section-text)
	   (setq purity-test-section-questions purity-test-R-section-questions)
	   (setq purity-test-question purity-test-R-question)
	   (setq purity-test-questions-text purity-test-R-questions-text)
	   (setq purity-test-questions purity-test-R-questions)
	   t))))

(defun purity-test-mode ()
  "Major mode to administer the purity test.    Keys are:
\\{purity-test-mode-map}"
  (use-local-map purity-test-mode-map)
  (define-key purity-test-mode-map " " 'purity-test-yes)
  (define-key purity-test-mode-map "?" 'describe-mode)
  (define-key purity-test-mode-map "S" 'purity-test-save)
  (define-key purity-test-mode-map "R" 'purity-test-restore)
  (define-key purity-test-mode-map "b" 'purity-test-backup)
  (define-key purity-test-mode-map "c" 'purity-test-current-score)
  (define-key purity-test-mode-map "d" 'purity-test-describe-section)
  (define-key purity-test-mode-map "e" 'purity-test-definitions)
  (define-key purity-test-mode-map "h" 'purity-test-history)
  (define-key purity-test-mode-map "i" 'purity-test-instructions)
  (define-key purity-test-mode-map "l" 'purity-test-liability)
  (define-key purity-test-mode-map "n" 'purity-test-no)
  (define-key purity-test-mode-map "s" 'purity-test-scoring)
  (define-key purity-test-mode-map "t" 'purity-test-title)
  (define-key purity-test-mode-map "q" 'purity-test-quit)
  (define-key purity-test-mode-map "w" 'purity-test-warranty)
  (define-key purity-test-mode-map "y" 'purity-test-yes)
  (define-key purity-test-mode-map "<DEL>" 'purity-test-no)
  (define-key purity-test-mode-map "\C-x<CTRL-C>" 'purity-test-quit)
  (define-key purity-test-mode-map "\C-x<CTRL-S>" 'purity-test-save)
  (setq mode-name "Purity Test")
  (setq major-mode 'purity-test-mode)
  (setq mode-line-format '(""
			   mode-name
			   " question "
			   purity-test-question-text
			   "    "
			   purity-test-section-name)))

(defun purity-test ()
  (interactive)
  (switch-to-buffer (get-buffer-create "*Purity Test*"))
  (setq buffer-read-only nil)
  (erase-buffer)
  (goto-char 0)
  (kill-all-local-variables)
  (setq buffer-read-only t)
  (setq purity-test-backup-ring ())
  (setq purity-test-score 0)
  (setq purity-test-section 0)
  (setq purity-test-section-name "")
  (setq purity-test-section-text "")
  (setq purity-test-section-questions ())
  (setq purity-test-question 0)
  (setq purity-test-question-text "")
  (setq purity-test-questions-text "")
  (setq purity-test-questions (purity-test-init-questions))
;;  (setq purity-test-questions (purity-test-test-questions))
  (setq purity-test-versionID (car purity-test-questions))
  (setq purity-test-questions (cdr purity-test-questions))
  (purity-test-mode)
  (purity-test-title)
  (purity-test-instructions)
  (cond ((file-exists-p purity-test-save-file)
	 (cond ((y-or-n-p "You have a saved test in progress.  Resume it? ")
		(purity-test-restore))
	       (t
		(purity-test-next-question))))
	(t
	 (purity-test-next-question))))


(defun purity-test-definitions ()
  (interactive)
  (purity-test-pop-up "Definitions"
"All questions in this test pertain to events that have happened to you
subsequent to your weaning and babyhood/infancy.  Anything that may have
happened before that time is considered not standing and void.

The term mutual masturbation refers to someone masturbating you AND/OR you
masturbating someone else, not exclusively both at the same time.

We would also like to define having sex in the homosexual case; homosexual sex
has occurred when both partners are of the same sex and one of the partners has
an orgasm while there is some contact between the genitals of both partners.

We would now like to bring to your attention that there is no passing nor
failing score.  Therefore, one really shouldn't worry too much about getting a
high score...  even if you do get giggled at for the rest of your life.
                       --- ALL TECHNICALITIES COUNT ---
"))

(defun purity-test-history ()
  (interactive)
  (purity-test-pop-up "Purity Test Genesis/History:"
"Version 1 (100) Created at MIT's Baker House.  Two parallel versions; one for
                male, and one for female.  Not much is known about this
                version.  It was ported to CMU by ps in 1982.
Version 2 (247) Spring 1983 - CMU/jb, pd, kr, ps, ts, mt, et al.
                Expanded to 247 questions.  This marked the beginning of
                the unisex versions. The story goes that they intended it to be
                250 questions, but got tired that night and said  'we'll  think
                of three more tomorrow', and tomorrow never got there.
Version 3.3C.1 (400) on 05-Dec-1984
                First  formal  release  general of this test, version 3.xx. All
                former versions were short-lived and tended to be bug-ridden.
                Does not discriminate against gays or bi's. Good correspondence
                of  scores (especially in the higher score ranges) between this
                version and version 2. Added Genesis/History section.
Version 3.4 (400) on 29-Jan-1985
                Internal version;  never  released.  Source  code  accidentally
                destroyed,  much  to  the  consternation of one of the authors.
                Cleaned up many bugs. Added sections: Disclaimer of  Liability,
                Instructions for Use, Scoring, and Warranty Information.
Version 3.5 (400) on 10-Apr-1985
                Rebuilt from the 3.3C.1 source and the 3.4 (only surviving
                copy) Xerox X9700 laser printer hardcopy.  Cleaned up same bugs
                in 3.4; wiped out a duplicate question.  Added in verbose
                history section.
Version 3.5A (400) on 13-Apr-1985:  CMU/da, fa, tc, no, dt, sv, rz, et al
                Found  that  we  had  431  questions  instead  of 400.
Version 3.5B (400) on 18-Mar-1986: Yale (Pierson College)/ as
                Intermediate release, with footnotes integrated into main body
                of text and some grammatical errors cleaned up.  Begun in
                Fall, 1985; finished in April for the benefit of a friend at
                MIT (where it all began), who hadn't seen any versions except
                the antique Version 1.
Version 3.5C (400) on 17-Jan-1988: Yale (Pierson College)/mmd (CLARINET@YALEVM)
                Grammatical errors corrected.  Introduction and history
                cleaned up.
Version 4.0 (500) on 23-April-1988: Yale (Silliman College)/dfc, ad, dcg, mlm,
                and Dartmouth (Alpha Theta)/alb.  Original 400-question version
                expanded to 500 questions.
Version 4.1 (500) in 1989 jkm and gwe from Univ. of Kentucky converted version
                4.0 to LaTeX
Version 4.1A (500) on 5-4-1989: Rutgers/rgm.   Version 4.0 converted into GNU
                emacs lisp."))

(defun purity-test-instructions ()
  (interactive)
  (purity-test-pop-up "Instructions for Use:"
"This is a fairly long test consisting of five hundred questions.  It starts out
tame and gets progressively worse (or better, depending on your viewpoint).
There are many ways of going about taking this test.  You can, of course, as
your right, guaranteed by the Constitution, be anti-social and sequester
yourself in your room and take this test all by yourself; however, we feel that
the funnest way to utilize this test is to hold a Purity Test Party.  All you
need is one copy of the test, and a bunch of friends.  (Lots of writing
implements and paper would be useful too.)  The person with the copy of the
test is the test administrator; s/he readsd the questions out loud and
everybody else writes down their answers.  We have no definite rules as to
whether the participants are required to divulge their answers; that is up to
the group to decide.  However, each person's purity score should be made common
knowledge.  (The person with the highest score gets to be giggled at for the
rest of his/her life.)  This works great at parties and lets everybody know
who's easy and who isn't, so you'll know who to go home with.  Don't leave home
without it."))

(defun purity-test-liability ()
  (interactive)
  (purity-test-pop-up "Disclaimer of Liability"
"The user of this test acknowledges that sex is a hazardous sport; that a person
must copulate in control, and use good judgement at all times; that partners'
conditions vary constantly and are greatly affected by weather changes and
previous use; and that dirty sheets, variations in terrain and bed surfaces,
spouses/pimps/managers, forest growth, rocks and debris, clothed obstacles, and
many other natural and man-made obstacles and hazards, including other users
and customers, exist throughout the bedroom area.  Personal managers
(pimps/spouses) and sado-masochistic operations and equipment are constantly in
use and may be hazardous to those not copulating in control.  Impotence,
collisions, and social diseases resulting in injury can happen at any time,
even to those copulating in control with proper sexual equipment.  Inherent
risks are part of the sport and may exist within your partner.  As a condition
of being permitted to use the facilities of your partner, the user of this test
agrees to copulate in control and within the limits of his/her ability, and
further acknowledges and accepts these hazards, dangers, and risks and assumes
the risk of injury or loss to person or damage to property which might result
from use of the partner's facilities.

As a further condition of being permitted to use the facilities of your
partner, the customer understands and agrees that:  
(1) 	In the event of a transfer of use by another or anything else in the
	management's opinion is misconduct, misuse, kinky, impotence, or
	nuisance, this service may be revoked without refund. 
(2)	the partner is the property of the harem and, upon request,
	s/he must be presented to any authorized representative of the 
	pimp/spouse.
(3)	sexual equipment must be visibly displayed at all times when you
	are in any bedroom and when approaching the bed to copulate.  Your
	sexual partner is not transferable; see Theft of Services, V.S.A.,
	sections 2581 and 2582."))

(defun purity-test-scoring ()
  (interactive)
  (purity-test-pop-up "Scoring"
"In this version of the purity test, emacs will do all the math for you.
But, if you had taken this test the old fashion way, you would have to
follow these directions.

Congratulations!  You are now the proud owner of a sheet of paper containing
lots of itty-bitty answers to the Purity Test.  Sworn to excellence of
workmanship, we now give you directions on how to calculate your Purity score.
There are several methods; the calculator method works best.  Also there is the
a la mainframe method.  (A DECsystem-2060 works great as a PC.)

Scoring method:  Count 'yes' answers.
                 Subtract that number from 500.
                 Divide the result by 5.
                 The result is your percentage purity.

The higher the number, the more pure you are; in the same vein, the lower the
score, the more of a sleaze-bag you are.

For your reference, we include calculator directions:
     For people with real calculators (HP):
               <# of NO answers> [ENTER] 5 /
     For people with other (dinky) calculators:
               <# of NO answers> / 5 ="))

(defun purity-test-title ()
  (interactive)
  (purity-test-pop-up
"                            THE UNISEX, OMNISEXUAL
                            P U R I T Y    T E S T"
"                             Version 4.0A (500)
 			    GNU Emacs Lisp Version
                                 5-May-1989

Public domain; no copyright.  All rights wronged, all wrongs reversed.  Up with
going down.  The risen flesh commands:  let there be love.  Murphy's law on
sex:  Love is a matter of chemistry; sex is a matter of physics.  Chaste makes
waste.  Virginity can be cured.

This document was not sponsored by the Department of Defense Advanced Research
Projects Agency, and was not monitored by the Air Force Avionics Laboratory.
The views and conclusions contained in this document should not be interpreted
as representing the official policies, either expressed or implied, of the
Defense Advanced Projects Agency or the US Government.  Neither should it be
interpreted nor inferred that the authors/contributors have actually performed
any of the actions contained herein.

	     Hit '?' For instructions on how to take the test

                       --- ALL TECHNICALITIES COUNT ---
"))

(defun purity-test-warranty ()
  (interactive)
  (purity-test-pop-up "Warranty Information"
"We  hope that you enjoy this test. It does not come with a warranty, nor
does it guarantee that it will get you laid or make you somehow somewhat better
in bed or the haystack.
The makers of this test are not responsible  for  any  liabilities  or  damages
resulting from this test, including but not limited to paternity suits.  Ask
your doctor or pharmacist.
Do not open back panel; no user serviceable parts inside.
Propagate (this test) at will, even without the written permission of the
publisher; just don't edit or change it.  In reproducing this test, the authors
of this test may exercise droit de seigneur over you, your immediate family, or
fiance(e).  You may or may not have additional rights which may vary from state
to state (i.e. inebriated, ecstacy).
Not recommended for children under twelve.  Parental guidance discouraged and
frowned upon.  Pencils, additional paper, and  batteries not included.  Some
assembly may be required.  Does not come with any other figures.

Drive carefully; 90% of the people in the world are caused by accidents."))
--