;;--------------------------------------------------------------------------
;; AriNET Project in Informatics IA by Dominique Guinard
;; dominique.guinard@unifr.ch
;;--------------------------------------------------------------------------
;; Read Eval Print
;;
;; Adapted from the source code of :
;; Autor: Lehmann Norbert + Jungo Dominik
;; Datum: 4.2.2003
;; Filename: ReadEvalPrint.scm
;;--------------------------------------------------------------------------
; ------------------------------------------------------------
; ABSTRACT:
; *********
; These are the functions used for building
; the Transcript Window and the Editor Window.
; It also contains various functions to interact with
; these windows, and to display results.
; ------------------------------------------------------------
; loading the PLT Framework libraries...
;(require (lib "framework.ss" "framework"))
; these variables are used for the transcript...
(define TranscriptWindow #f)
(define TranscriptEditor #f)
; *************************************************************************
; DESCRIPTION: Some fonctions for writting into the transcript...
(define (transcript_welcome)
(send TranscriptEditor insert "Welcome to AriNET ..."))
(define (transcript_prompt)
(send TranscriptEditor set-position (send TranscriptEditor last-position))
(send TranscriptEditor insert #\newline)
(send TranscriptEditor insert "> "))
(define (print-error-msg theMessage)
(print-to-transcript (string-append "ERROR -- " theMessage))
(transcript_prompt))
(define (print-newline)
(send TranscriptEditor insert #\newline))
(define (print-to-transcript TheThing)
(let ((NewString (ConvertToString TheThing)))
(send TranscriptEditor set-position (send TranscriptEditor last-position))
(send TranscriptEditor insert #\newline)
(send TranscriptEditor insert NewString)))
; *************************************************************************
; DESCRIPTION: Functions for converting strings and lists...
(define (ConvertToString TheThing)
(cond ((string? TheThing) (string-append "\"" TheThing "\""))
((number? TheThing) (number->string TheThing))
((symbol? TheThing) (symbol->string TheThing))
((primitive-procedure? TheThing) "#<PRIM-PROC>")
((compound-procedure? TheThing) "#<COMPOUND-PROC>")
;modified from : ((list? TheThing) (list->string TheThing)), in order to handle
;the '() sent back by get-value.
((list? TheThing) (if (null? TheThing)
"()"
(list->string TheThing)))
((pair? TheThing) (string-append "("
(ConvertToString (car TheThing))
" . "
(ConvertToString (cdr TheThing))
")"))
((eq? TheThing #f) "#f")
((eq? theThing #t) "#t")
(else "")))
; Convert a list into a string (attention, apply must be the "apply" from DrScheme)...
(define (list->string theList)
(string-append "("
(ConvertToString (car theList))
(apply string-append
(map (lambda (item)
(string-append " " (ConvertToString item)))
(cdr theList)))
")"))
; Convert a string into a list...
(define (extended-read string-from-port)
(define (build-list-of-objects current-port)
(let ((new-object (read current-port)))
(if (eof-object? new-object)
'()
(cons new-object
(build-list-of-objects current-port)))))
(let ((myport (open-input-string string-from-port)))
(build-list-of-objects myport)))
; *************************************************************************
; DESCRIPTION: The driver-loop -> "read-eval-print" loop
(define (driver-loop)
(with-handlers ([exn? (lambda (exn) (errormsg (exn-message exn) 'scheme))])
(reset-errors)
(let* ((EndPos (send TranscriptEditor get-end-position))
(StartPos (find-start-position EndPos)))
(if StartPos
(if (scheme-paren:balanced? TranscriptEditor StartPos EndPos)
(let* ((theText (send TranscriptEditor get-text StartPos EndPos #f #f))
(TheSequence (extended-read theText))
(TheResult (my-eval (car TheSequence) the-global-environment)))
(print-to-transcript TheResult)
(transcript_prompt))
(send TranscriptEditor insert #\newline))
(transcript_prompt)))))
(define (driver-loop-for-gui command)
(with-handlers ([exn? (lambda (exn) (errormsg (exn-message exn) 'scheme))])
(reset-errors)
(let ((TheResult (my-eval command the-global-environment)))
(print-to-transcript TheResult))
(transcript_prompt)))
; *************************************************************************
; DESCRIPTION: Searchs the current expression. The result is the starting
; position. We will search the character #\> preceded by
; the character #\newline.
(define (find-start-position EndPos)
(define (iterSearch pos)
(cond ((< pos 0) #f)
((and (char=? (send TranscriptEditor get-character pos) #\>)
(char=? (send TranscriptEditor get-character (- pos 1)) #\newline))
(+ pos 2))
(else (iterSearch (- pos 1)))))
(IterSearch (- EndPos 1)))
; *************************************************************************
; DESCRIPTION: The editor class for the transcript...
(define transcript:return%
(class text:return% (init (return driver-loop))
(super-instantiate () (return return))))
(define transcript:editor% (scheme:text-mixin transcript:return%))
; *************************************************************************
; DESCRIPTION: The frame classes used for the transcript and the editor...
(define my-frame%
(class frame:searchable% (init label width height x y style) (init-field editor-class)
(rename
(old-can-close? can-close?))
(public*
(extern-can-close? (lambda () (old-can-close?))))
(override*
;overriding the exit procedure (avoinding killing the thread)
;(file-menu:quit-callback (lambda (x y) (my-quit-proc x y)))
;(file-menu:close-callback (lambda (x y) (my-close-proc x y)))
(file-menu:new-callback (lambda (x y) (my-new-proc x y)))
(file-menu:open-callback (lambda (x y) (my-open-proc x y)))
(file-menu:save-as-callback (lambda (x y) (my-save-proc x y)))
(help-menu:about-string (lambda () (my-about-string-proc)))
(help-menu:about-callback (lambda (x y) (my-about-callback-proc x y)))
(help-menu:create-about? (lambda () (my-create-about?-proc)))
(get-editor<%> (lambda () scheme:text<%>))
(get-editor% (lambda () editor-class)))
(pref-proc)
(super-instantiate (label) (width width) (height height) (x x) (y y) (style style))))
(define frame:transcript%
(class my-frame% (init label width height x y style)
(super-instantiate (label width height x y style)
(editor-class transcript:editor%))))
(define frame:scheme-editor%
(class my-frame% (init label width height x y style)
(super-instantiate (label width height x y style) (editor-class scheme:text%))))
; *************************************************************************
; DESCRIPTION: Creating of the transcript window...
(define (setup-transcript)
(let ((x (get-display-divided-size 'x 2))
(y (get-display-divided-size 'y 2)))
(set! TranscriptWindow
(instantiate frame:transcript% ("Transcript Window"
x
y
(get-center-position 'x x y)
(get-center-position 'y x y)
'(no-resize-border))))
(set! TranscriptEditor (send TranscriptWindow get-editor))
(send TranscriptEditor erase)
(transcript_welcome)
(transcript_prompt)
(add-menus TranscriptWindow)
(send TranscriptWindow show #t)))
; *************************************************************************
; DESCRIPTION: Functions for the menus...
(define (my-open-proc item control)
(let ((theFile (finder:get-file)))
(if theFile
(let* ((x (get-display-divided-size 'x 4))
(y (get-display-divided-size 'y 4))
(theWindow (make-object frame:scheme-editor%
(file-name-from-path theFile)
x
y
(get-center-position 'x x y)
(get-center-position 'y x y)
'())))
(send (send theWindow get-editor) load-file theFile 'text #f)
(add-menus theWindow)
(send theWindow show #t)))))
(define (my-new-proc item control)
(let* ((x (get-display-divided-size 'x 4))
(y (get-display-divided-size 'y 4))
(theWindow (make-object frame:scheme-editor%
(gui-utils:next-untitled-name)
x
y
(get-center-position 'x x y)
(get-center-position 'y x y)
'())))
(add-menus theWindow)
(send theWindow show #t)))
(define (my-open-editor item control)
(let* ((x (get-display-divided-size 'x 4))
(y (get-display-divided-size 'y 4))
(theWindow (make-object frame:scheme-editor%
"Editor Window"
x
y
(get-center-position 'x x y)
(get-center-position 'y x y)
'())))
(add-menus theWindow)
(send theWindow show #t)))
(define (my-save-proc item control)
(let ((theWindow (send (send (send item get-parent) get-parent) get-frame))
(theFile (finder:put-file)))
(when theFile
(send (send theWindow get-editor) save-file theFile 'text #f)
(send theWindow set-label (file-name-from-path theFile)))))
(define (my-quit-proc item control)
(let ((theWindow (send (send (send item get-parent) get-parent) get-frame)))
(if (symbol=? (message-box "Exit" "Are you sure you want to quit ?" #f
'(yes-no)) 'yes)
(send theWindow show #f))))
(define (my-close-proc item control)
(let ((theWindow (send (send (send item get-parent) get-parent) get-frame)))
(if (symbol=? (message-box "Exit"
"Are you sure you want to close the window ?" #f '(yes-no)) 'yes)
(send theWindow show #f))))
(define (my-about-string-proc)
"About AriNET...")
(define (my-create-about?-proc)
#t)
(define (my-about-callback-proc item control)
(about-box))
(define (online-doc item control)
(with-handlers ([exn? (lambda (exn)
((message-box "Online Documentation" "To find the latest documentation
please visit: http://www.gmipsoft.com/unifr/arinet" #f '(ok))))])
(shell-execute #f "http://www.gmipsoft.com" "" (current-directory) 'SW_SHOWNORMAL)))
(define (report-bug item control)
(with-handlers ([exn? (lambda (exn)
((message-box "Reporting a bug" "To report a bug, please send an email to:
dominique.guinard@unifr.ch, together with the error message you got
and the context of evaluation. (evaluated commands, set variables...)" #f '(ok))))])
(shell-execute #f "mailto:dominique.guinard@unifr.ch" ""
(current-directory) 'SW_SHOWNORMAL)))
(define (contact-author item control)
(with-handlers ([exn? (lambda (exn)
((message-box "Contact" "To contact the author please feel free to send
an email to: dominique.guinard@unifr.ch" #f '(ok))))])
(shell-execute #f "mailto:dominique.guinard@unifr.ch" ""
(current-directory) 'SW_SHOWNORMAL)))
(define (drscheme-website item control)
(with-handlers ([exn? (lambda (exn)
((message-box "DrScheme Website" "To get information about the underlying Scheme
of AriNET please visit: http://www.drscheme.org" #f '(ok))))])
(shell-execute #f "http://www.drscheme.org" "" (current-directory) 'SW_SHOWNORMAL)))
(define (my-exemples MItem CEvent type)
(cond ((symbol=? type 'pythagoras1)
(open-exemple "Exemple 1: Pythagoras" (build-path "exemples" "pythagoras1.scm")))
((symbol=? type 'pythagoras2)
(open-exemple "Exemple 2: Pythagoras with modules"
(build-path "exemples" "pythagoras2.scm")))
((symbol=? type 'my-square)
(open-exemple "Exemple 3: My-square"
(build-path "exemples" "my_sqrt.scm")))
((symbol=? type 'simple-interest)
(open-exemple "Exemple 4: Simple-interest"
(build-path "exemples" "simple_interest.scm")))
(else
(errormsg "Unable to open the selected exemple" 'code))))
(define (open-exemple title file)
(with-handlers ([exn? (lambda (exn)
((errormsg "Unable to open the selected exemple" 'code)))])
(let* ((x (get-display-divided-size 'x 4))
(y (get-display-divided-size 'y 4))
(theWindow (make-object frame:scheme-editor%
title
x
y
(get-center-position 'x x y)
(get-center-position 'y x y)
'())))
(send (send theWindow get-editor) load-file
file
'text
#f)
(add-menus theWindow)
(send theWindow show #t))))
(define (pref-proc)
;adding the preferences panels
(preferences:add-font-panel)
(preferences:add-editor-checkbox-panel)
(preferences:add-warnings-checkbox-panel)
(scheme:add-preferences-panel))
(define (simulation-menu givenMenubar)
(define (simulation-proc MItem CEvent)
(display "Not implemented yet, but coming soon !"))
(let* ((aSimulationMenu (make-object menu% "Simulation" givenMenubar)))
(instantiate menu-item% ("Eval Selection" aSimulationMenu (lambda (x y)
(eval-selection-proc x y))))
(instantiate menu-item% ("Eval Window" aSimulationMenu (lambda (x y)
(eval-window-proc x y))))
(instantiate menu-item% ("Reset" aSimulationMenu (lambda (x y) (reset-proc x y))))
(instantiate menu-item% ("Clear Transcript" aSimulationMenu (lambda (x y)
(clear-proc x y))))
(instantiate separator-menu-item% (aSimulationMenu))
(instantiate menu-item% ("Set Value" aSimulationMenu (lambda (x y)
(set-value-box-proc x y))))
(instantiate menu-item% ("Get Value" aSimulationMenu (lambda (x y)
(get-value-box-proc x y))))
(instantiate menu-item% ("Forget Value" aSimulationMenu (lambda (x y)
(forget-value-box-proc x y))))
(instantiate separator-menu-item% (aSimulationMenu))
(instantiate menu-item% ("Get All Values" aSimulationMenu (lambda (x y)
(get-all-values-proc x y *VARIABLES*))))))
(define (font-menu givenMenubar)
(let ((aFontMenu (instantiate menu% ("Font" givenMenubar))))
(append-editor-font-menu-items aFontMenu)))
(define (debug-menu givenMenubar)
(define (simulation-proc MItem CEvent)
(display "Not implemented yet, but coming soon !"))
(let ((aDebugMenu (instantiate menu% ("Debug" givenMenubar))))
(instantiate menu-item% ("Display only first error" aDebugMenu
(lambda (x y) (only-first-error-proc x y))))
(instantiate menu-item% ("Display all errors" aDebugMenu
(lambda (x y) (all-errors-proc x y))))))
(define (misc-menu givenMenubar)
(let* ((aMisc-menu (make-object menu% "Misc" givenMenubar)))
(instantiate menu-item% ("Online documentation" aMisc-menu (lambda (x y)
(online-doc x y))))
(instantiate menu-item% ("Report a bug" aMisc-menu (lambda (x y) (report-bug x y))))
(instantiate menu-item% ("Contact the author" aMisc-menu (lambda (x y)
(contact-author x y))))
(instantiate menu-item% ("DrScheme's website" aMisc-menu (lambda (x y)
(drscheme-website x y))))
(instantiate separator-menu-item% (aMisc-menu))
(instantiate menu-item% ("Exemple 1: Pythagoras" aMisc-menu (lambda (x y)
(my-exemples x y 'pythagoras1))))
(instantiate menu-item% ("Exemple 2: Pythagoras with modules" aMisc-menu (lambda (x y)
(my-exemples x y 'pythagoras2))))
(instantiate menu-item% ("Exemple 3: My square" aMisc-menu (lambda (x y)
(my-exemples x y 'my-square))))
(instantiate menu-item% ("Exemple 4: Simple Interest" aMisc-menu (lambda (x y)
(my-exemples x y 'simple-interest))))))
(define (add-menus givenFrame)
(let ((theMenubar (send givenFrame get-menu-bar)))
(debug-menu theMenubar)
(font-menu theMenubar)
(simulation-menu theMenubar)
(misc-menu theMenubar)
(frame:reorder-menus givenFrame)))
; ------------------------------------------------------------
; Functions for the simulation menu
; ------------------------------------------------------------
(define (eval-selection-proc MItem CEvent)
(with-handlers ([exn? (lambda (exn) (errormsg (exn-message exn) 'scheme))])
(reset-errors)
(let ((theWindow (get-top-level-focus-window)))
(let* ((ed (send theWindow get-editor))
(start (send ed get-start-position))
(end (send ed get-end-position))
(theText (send ed get-text start end #f #f)))
(unless (= (string-length theText ) 0)
(if (scheme-paren:balanced? ed start end)
(let ((theList (extended-read theText)))
(eval-sequence theList the-global-environment)
(print-to-transcript "DONE -- Eval Selection")
(transcript_prompt))
(print-error-msg "unmatched parenthesis, please check them and try once again.")))))))
(define (eval-window-proc MItem CEvent)
(with-handlers ([exn? (lambda (exn) (errormsg (exn-message exn) 'scheme))])
(reset-errors)
(let ((theWindow (get-top-level-focus-window)))
(unless (eq? theWindow TranscriptWindow)
(let* ((ed (send theWindow get-editor))
(start 0)
(theText (send ed get-text 0 'eof #f #f))
(end (string-length theText)))
(unless (= (string-length theText ) 0)
(if (scheme-paren:balanced? ed start end)
(let ((theList (extended-read theText)))
(eval-sequence theList the-global-environment)
(print-to-transcript "DONE -- Eval Window")
(transcript_prompt))
(print-error-msg "Unmatched parenthesis, please check
them and try once again."))))))))
(define (reset-proc MItem CEvent)
(if (symbol=? (message-box "Exit" "This is going to erase all your constraints,
modules and defined variables, do you wish to continue anyway?" #f '(yes-no)) 'yes)
(begin
(reset-the-global-environment)
(reset-variables)
(reset-modules)
(send TranscriptEditor erase)
(print-to-transcript "DONE -- Reset")
(transcript_prompt))))
(define (clear-proc MItem CEvent)
(send TranscriptEditor erase)
(transcript_prompt))
(define (get-all-values-proc MItem CEvent set-of-vars)
(if (null? set-of-vars)
(begin
(print-to-transcript "DONE -- Get all values")
(transcript_prompt))
(begin
(print-to-transcript (car set-of-vars))
(print-to-transcript (my-eval (list 'get-value
(car set-of-vars))
the-global-environment))
(print-newline)
(get-all-values-proc MItem CEvent (cdr set-of-vars)))))
;the specific functions handeling the value dialogs
;(set-value, get-value, forget-value) are to be found in the valuedialogs.scm file.
; ------------------------------------------------------------
; end of functions for the simulation menu
; ------------------------------------------------------------
;;--------------------------------------------------------------------------
;; end of Read Eval Print
;;--------------------------------------------------------------------------