home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / 6001 / edextra.scm < prev    next >
Text File  |  2000-12-01  |  15KB  |  421 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: edextra.scm,v 1.32 2000/12/01 06:41:21 cph Exp $
  4.  
  5. Copyright (c) 1992-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; 6.001: Edwin Extensions
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define student-root-directory)
  27. (define student-work-directory)
  28. (define pset-directory)
  29. (define pset-list-file)
  30. (define command-line-student-directory #f)
  31.  
  32. (set-command-line-parser! "-student" 
  33.   (lambda (command-line)
  34.     (let ((name (cadr command-line)))
  35.       (if (file-directory? name)
  36.       (set! command-line-student-directory (->pathname name)))
  37.       (values (cddr command-line) #F))))
  38.  
  39. (set! standard-editor-initialization
  40.       (let ((usual standard-editor-initialization))
  41.     (lambda ()
  42.       (usual)
  43.       (standard-login-initialization))))
  44.  
  45. (define (standard-login-initialization)
  46.   (set! student-root-directory
  47.     (if (and command-line-student-directory
  48.          (file-directory? command-line-student-directory))
  49.         (pathname-as-directory command-line-student-directory)
  50.         (let ((6001-dir
  51.            (get-environment-variable "MITSCHEME_6001_DIRECTORY")))
  52.           (if (and 6001-dir (file-directory? 6001-dir))
  53.           (pathname-as-directory 6001-dir)
  54.           "~u6001/"))))
  55.   (set! student-work-directory
  56.     (merge-pathnames "work/" student-root-directory))
  57.   (if (not (file-directory? student-root-directory))
  58.       (set! student-root-directory (user-homedir-pathname)))
  59.   (if (not (file-directory? student-work-directory))
  60.       (set! student-work-directory (user-homedir-pathname)))
  61.   (set! pset-directory (merge-pathnames "psets/" student-root-directory))
  62.   (set! pset-list-file (merge-pathnames "probsets.scm" pset-directory))
  63.   (set-default-directory student-work-directory)
  64.   (set-working-directory-pathname! student-work-directory)
  65.   (let ((hairy-floppy-stuff?
  66.      (and (eq? 'UNIX microcode-id/operating-system)
  67.           (string-ci=? "HP-UX" microcode-id/operating-system-variant))))
  68.     (if hairy-floppy-stuff?
  69.     (run-floppy-login-loop))
  70.     (let ((pathname (merge-pathnames "motd" student-root-directory)))
  71.       (if (file-exists? pathname)
  72.       (let ((buffer (temporary-buffer "*motd*")))
  73.         (call-with-current-continuation
  74.          (lambda (k)
  75.            (bind-condition-handler (list condition-type:file-error)
  76.            (lambda (condition)
  77.              condition
  78.              (kill-buffer buffer)
  79.              (k unspecific))
  80.          (lambda ()
  81.            (%insert-file (buffer-start buffer) pathname false)))
  82.            (set-buffer-point! buffer (buffer-start buffer))
  83.            (select-buffer buffer))))))
  84.     (if hairy-floppy-stuff?
  85.     (message "Login completed."))))
  86.  
  87. (define-command logout
  88.   "Logout from the 6.001 Scheme system."
  89.   ()
  90.   (lambda ()
  91.     (fluid-let ((paranoid-exit? false))
  92.       ((ref-command save-buffers-kill-scheme) #f))))
  93.  
  94. (define (restore-focus-to-editor)
  95.   (let ((name (graphics-type-name (graphics-type #f))))
  96.     (case name
  97.       ((X)
  98.        (let ((screen (selected-screen)))
  99.      (if (xterm-screen/grab-focus! screen)
  100.          (xterm-screen/flush! screen))))
  101.       ((WIN32)
  102.        ((access set-focus (->environment '(win32)))
  103.     ((access get-handle (->environment '(win32))) 1)))
  104.       ((OS/2)
  105.        (os2-screen/activate! (selected-screen)))
  106.       (else
  107.        (error "Unsupported graphics type:" name)))))
  108.  
  109. (environment-link-name '(student pictures)
  110.                '(edwin)
  111.                'restore-focus-to-editor)
  112.  
  113. (if (eq? 'UNIX microcode-id/operating-system)
  114.     (load-edwin-library 'PRINT))
  115.  
  116. (define-command print-graphics
  117.   "Print out window with graphics."
  118.   '()
  119.   (lambda ()
  120.     (let ((window (prompt-for-expression-value "Window to print" 'mouse)))
  121.       (if (eq? window 'mouse)
  122.       (print-pointed-x-window)
  123.       (if (graphics-device? window)
  124.           (print-given-x-window (x-graphics/window-id window))
  125.           (editor-error "Not a window object!"))))))
  126.  
  127. (define (print-given-x-window x-window-id)
  128.   ((message-wrapper #f "Spooling")
  129.    (lambda ()
  130.      (shell-command
  131.       false false false false
  132.       (string-append (->namestring
  133.               (merge-pathnames "bin/print-given-x-window"
  134.                        student-root-directory))
  135.              " 0x"
  136.              (number->string x-window-id 16)
  137.              " "
  138.              (print/assemble-switches "Scheme Picture" '()))))))
  139.  
  140. (define (print-pointed-x-window)
  141.   ((message-wrapper #f "Click desired window")
  142.    (lambda ()
  143.      (shell-command
  144.       false false false false
  145.       (string-append (->namestring
  146.               (merge-pathnames "bin/print-pointed-x-window"
  147.                        student-root-directory))
  148.              " "
  149.              (print/assemble-switches "Scheme Picture" '()))))))
  150. #|
  151. ;;; If using pointer (mouse).
  152.  
  153. xwd | /usr/local/pbmbin/xwdtopnm | /usr/local/pbmbin/ppmtopgm | /usr/local/pbmbin/pnmscale 4 | /usr/local/pbmbin/pgmtopbm -cluster4 | /usr/local/pbmbin/pbmtolj -resolution 300 | lpr -h
  154.  
  155. ;;; If using *** = x-graphics/window-id
  156.  
  157. xwd -id *** | /usr/local/pbmbin/xwdtopnm | /usr/local/pbmbin/ppmtopgm | /usr/local/pbmbin/pnmscale 4 | /usr/local/pbmbin/pgmtopbm -cluster4 | /usr/local/pbmbin/pbmtolj -resolution 300 | lpr -h
  158.  
  159. Now, there is formatting stuff to be considered here, in print-pgm.sh.
  160. |#
  161.  
  162. ;;;; EDWIN Command "Load Problem Set"
  163.  
  164. ;;; Wired-in pathnames
  165.  
  166. ;;; The structure "problem-sets" must be loaded from pset-list-file whenever
  167. ;;; the set of available problem sets changes, or when the default
  168. ;;; problem set changes.  Files should appear with name and extension, but
  169. ;;; without device, directory, or version; these will be supplied
  170. ;;; automatically.
  171. ;;;
  172. ;;; Example problem-sets variable:
  173.  
  174. ;(define problem-sets
  175. ;  `(1 (1  (load&reference "ps1-c-curve.scm" "ps1-debug.scm"))
  176. ;      (2  (copy "ps2-ans.scm") (load&reference "ps2-primes.scm"))
  177. ;      (3  (copy "ps3-ans.scm")
  178. ;      (load&reference "ps3-squares.scm" "ps3-tri.scm"))
  179. ;      (4  (copy "ps4-ans.scm") (load&reference "ps4-doctor.scm")
  180. ;      (select "ps4-ans.scm"))
  181. ;      (5  (copy "ps5-ans.scm")
  182. ;      (load&reference "ps5-graph.scm" "ps5-imp.scm" "ps5-res.scm"))
  183. ;      (6  (copy "ps6-mods.scm") (load&reference "ps6-adv.scm"))
  184. ;      (7  (copy "ps7-ans.scm")
  185. ;      (load&reference "ps7-ps.scm" "ps7-psutil.scm" "ps7-ratnum.scm"))
  186. ;      (8  (copy "ps8-mods.scm") (load&reference "ps8-mceval.scm"))))
  187.  
  188. ;;; Data abstraction for the "problem-sets" object:
  189.  
  190. (define problem-sets/default-ps car)
  191. (define problem-sets/psets cdr)
  192. (define psets/first-pset car)
  193. (define psets/rest-psets cdr)
  194. (define psets/empty? null?)
  195. (define pset/ps car)
  196. (define pset/groups cdr)
  197. (define (groups/files-to-copy groups)
  198.   (let ((any (assq 'copy groups)))
  199.     (if any (cdr any) '())))
  200. (define (groups/files-to-load groups)
  201.   (let ((any (assq 'load groups)))
  202.     (if any (cdr any) '())))
  203. (define (groups/files-to-reference groups)
  204.   (let ((any (assq 'reference groups)))
  205.     (if any (cdr any) '())))
  206. (define (groups/files-to-load&reference groups)
  207.   (let ((any (assq 'load&reference groups)))
  208.     (if any (cdr any) '())))
  209. (define (groups/buffer-to-select groups)
  210.   (let ((any (assq 'select groups)))
  211.     (if any (cadr any) '())))
  212. (define (groups/all-files groups)
  213.   (merge-lists (groups/files-to-copy groups)
  214.            (groups/files-to-load groups)
  215.            (groups/files-to-reference groups)
  216.            (groups/files-to-load&reference groups)))
  217.  
  218. ;;; Procedure to get the "files" object corresponding to a particular
  219. ;;; problem set.  Runs error-handler (which should never return) if
  220. ;;; the problem set number is not listed in the "problem-sets" object.
  221.  
  222. (define (ps-groups ps error-handler)
  223.   (let loop ((remaining-psets (problem-sets/psets problem-sets)))
  224.     (if (psets/empty? remaining-psets)
  225.     (error-handler)
  226.     (let ((first-ps (psets/first-pset remaining-psets)))
  227.       (if (string=? ps (->string (pset/ps first-ps)))
  228.           (pset/groups first-ps)
  229.           (loop (psets/rest-psets remaining-psets)))))))
  230.  
  231. ;;; Horribly inefficient procedure to merge lists, ensuring that no member
  232. ;;; is repeated in the resulting list.
  233. (define (merge-lists . lists)
  234.   (let ((one-list (apply append lists)))
  235.     (let loop ((remaining one-list)
  236.            (accumulated '()))
  237.       (if (null? remaining)
  238.       accumulated
  239.       (let ((first (car remaining))
  240.         (rest (cdr remaining)))
  241.         (if (memq first rest)
  242.         (loop rest accumulated)
  243.         (loop rest (cons first accumulated))))))))
  244.  
  245. ;;; Returns #t iff FILES all exist in DIRECTORY.
  246. (define (files-all-exist? files directory)
  247.   (for-all? files
  248.     (lambda (file)
  249.       (file-exists? (merge-pathnames directory file)))))
  250.  
  251. (define-command load-problem-set
  252.   "Load a 6.001 problem set."
  253.   ()
  254.   (lambda ()
  255.     (load-quietly pset-list-file '(EDWIN))
  256.     (let* ((ps
  257.         (prompt-for-string "Load Problem Set"
  258.                    (->string
  259.                 (problem-sets/default-ps problem-sets))))
  260.        (error-handler
  261.         (lambda ()
  262.           (editor-error "There doesn't appear to be a problem set "
  263.                 ps
  264.                 " installed; ask a TA for help.")))
  265.        (groups (ps-groups ps error-handler))
  266.        (pset-path
  267.         (merge-pathnames (string-append "ps" ps "/") pset-directory)))
  268.       (if (not (files-all-exist? (groups/all-files groups) pset-path))
  269.       (error-handler))
  270.       (for-each (lambda (file)
  271.           (find-file-noselect (merge-pathnames file pset-path) #t))
  272.         (groups/files-to-reference groups))
  273.       (for-each (lambda (file)
  274.           (let ((filename (merge-pathnames file pset-path)))
  275.             ((message-wrapper #f
  276.                       "Evaluating file "
  277.                       (->namestring filename))
  278.              (lambda ()
  279.                (load-quietly filename '(STUDENT))))))
  280.         (groups/files-to-load groups))
  281.       (for-each (lambda (file)
  282.           (let ((filename (merge-pathnames file pset-path)))
  283.             ((message-wrapper #f
  284.                       "Evaluating file "
  285.                       (->namestring filename))
  286.              (lambda ()
  287.                (load-quietly filename '(STUDENT))))
  288.             (find-file-noselect filename #t)))
  289.         (groups/files-to-load&reference groups))
  290.       (for-each (lambda (file)
  291.           (load-ps-copy-file file pset-path student-work-directory))
  292.         (groups/files-to-copy groups)))))
  293.  
  294. (define (load-quietly pathname environment)
  295.   (fluid-let ((load/suppress-loading-message? #t))
  296.     (load pathname environment)))
  297.  
  298. (define (->string object)
  299.   (if (string? object)
  300.       object
  301.       (with-output-to-string (lambda () (display object)))))
  302.  
  303. (define (load-ps-copy-file file source-dir dest-dir)
  304.   (let ((source-file (merge-pathnames file source-dir))
  305.     (dest-file (merge-pathnames file dest-dir))
  306.     (filename (->namestring file)))
  307.     (if (file-exists? dest-file)
  308.     (let* ((backup-pathname (pathname-new-type file "bak"))
  309.            (backup-filename (->namestring backup-pathname)))
  310.       (with-saved-configuration
  311.        (lambda ()
  312.          (delete-other-windows (current-window))
  313.          (let ((buffer (temporary-buffer " *load-problem-set-dialog*")))
  314.            (select-buffer buffer)
  315.            (append-string
  316.         "This problem set contains a file named ")
  317.            (append-string
  318.         (write-to-string filename))
  319.            (append-string ",
  320. but your working directory already contains a file of that name.
  321.  
  322. Answer \"yes\" to replace your file with the file from the problem set.
  323. If you choose this option your file will be renamed \"")
  324.            (append-string backup-filename)
  325.            (append-string "\".
  326.  
  327. Otherwise answer \"no\" to leave your file unchanged; if you choose this
  328. option the file from the problem set will not be installed.
  329. "))
  330.          (if (prompt-for-yes-or-no? "Install problem set file")
  331.          (begin
  332.            (append-string
  333.             (string-append "\nRenaming \""
  334.                    filename
  335.                    "\" to \""
  336.                    backup-filename
  337.                    "\"..."))
  338.            (rename-ps-file dest-file backup-pathname)
  339.            (append-string
  340.             (string-append "done\n\nCopying file \""
  341.                    filename
  342.                    "\" to working area..."))
  343.            (copy-ps-file source-file dest-file)
  344.            (append-string "done"))
  345.          (begin
  346.            (append-string "\nOK, not using problem set file.")
  347.            (find-file-noselect dest-file #t))))))
  348.     (let ((msg
  349.            (string-append "Copying file \""
  350.                   filename
  351.                   "\" to working area...")))
  352.       (message msg)
  353.       (copy-ps-file source-file dest-file)
  354.       (message msg "done")))))
  355.  
  356. (define (rename-ps-file from-file to-file)
  357.   (call-with-current-continuation
  358.    (lambda (k)
  359.      (bind-condition-handler (list condition-type:file-error
  360.                    condition-type:port-error)
  361.      (lambda (condition)
  362.        condition
  363.        (k unspecific))
  364.        (lambda ()
  365.      (delete-file to-file)))))
  366.   (bind-condition-handler (list condition-type:file-error
  367.                 condition-type:port-error)
  368.       (lambda (condition)
  369.     (editor-error "Rename failed: "
  370.               (condition/report-string condition)))
  371.     (lambda ()
  372.       (rename-file from-file to-file))))
  373.  
  374. (define (copy-ps-file from-file to-file)
  375.   (let ((buffer (find-file-noselect from-file #t)))
  376.     (set-buffer-writeable! buffer)
  377.     (set-visited-pathname buffer to-file)
  378.     (write-buffer buffer)))
  379.  
  380. ;;;; Customization
  381.  
  382. (set! default-homedir-pathname (lambda () student-work-directory))
  383.  
  384. (set! editor-can-exit? false)
  385. (set! scheme-can-quit? false)
  386. (set! paranoid-exit? true)
  387.  
  388. (set-variable! enable-transcript-buffer true)
  389. (set-variable! evaluate-in-inferior-repl true)
  390. (set-variable! repl-error-decision true)
  391. (set-variable! version-control true)
  392. (set-variable! trim-versions-without-asking true)
  393.  
  394. #|
  395. ;; No longer needed.
  396. (if (eq? 'UNIX microcode-id/operating-system)
  397.     (set-variable!
  398.      mail-header-function
  399.      (let ((default-reply-to false))
  400.        (lambda (point)
  401.      (let ((reply-to
  402.         (prompt-for-string "Please enter an email address for replies"
  403.                    default-reply-to
  404.                    'DEFAULT-TYPE 'INSERTED-DEFAULT)))
  405.        (if (not (string-null? reply-to))
  406.            (begin
  407.          (set! default-reply-to reply-to)
  408.          (insert-string "From: " point)
  409.          (insert-string reply-to point)
  410.          (insert-newline point)
  411.          (insert-string "Reply-to: " point)
  412.          (insert-string reply-to point)
  413.          (insert-newline point))))))))
  414. |#
  415.  
  416. (set-variable! select-buffer-not-found-hooks
  417.            (cons (lambda (name)
  418.                (find-file-noselect
  419.             (merge-pathnames name student-work-directory)
  420.             true))
  421.              (ref-variable select-buffer-not-found-hooks)))