#lang scheme ;; ################################################################################## ;; # ============================================================================== # ;; # controller.ss # ;; # http://mred-designer.origo.ethz.ch # ;; # Copyright (C) Laurent Orseau, 2010 # ;; # ============================================================================== # ;; # # ;; # This program is free software; you can redistribute it and/or # ;; # modify it under the terms of the GNU General Public License # ;; # as published by the Free Software Foundation; either version 2 # ;; # of the License, or (at your option) any later version. # ;; # # ;; # This program is distributed in the hope that it will be useful, # ;; # but WITHOUT ANY WARRANTY; without even the implied warranty of # ;; # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # ;; # GNU General Public License for more details. # ;; # # ;; # You should have received a copy of the GNU General Public License # ;; # along with this program; if not, write to the Free Software # ;; # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # ;; # # ;; ################################################################################## (require "mreddesigner-misc.ss" "preview-widgets.ss" "toolbox-frame.ss" "property-frame.ss" "hierarchy-frame.ss" "code-generation.ss" "templates.ss" framework "mred-plugin.ss" ; for project loading: scheme/gui/base "mred-id.ss" ) ; This module makes the binding between the different frames and the model. (define/provide (controller-exit-application) (debug-printf "controller-exit-application:~n") (let ([projects (map-send user-data (send hierarchy-widget get-items))]) (for-each project-changed-save projects) ) (close-window hierarchy-frame) (close-window property-frame) (close-window toolbox-frame) ) (define/provide (controller-show-property-frame) (debug-printf "controller-show-property-frame:~n") (send property-frame show (not (send property-frame is-shown?)))) (define/provide (controller-show-hierarchy-frame) (debug-printf "controller-show-hierarchy-frame:~n") (send hierarchy-frame show (not (send hierarchy-frame is-shown?)))) (define/provide (controller-select-mred-id mid) (debug-printf "controller-select-mred-id: mid:~a~n" mid) (select-mred-id mid) (hierarchy-select mid) (update-property-frame mid) (update-toolbox-frame mid) ) (define/provide (controller-replace-current-widget) (debug-printf "controller-replace-current-widget: enter~n") (send (get-current-mred-id) replace-widget) (send hierarchy-widget update-current-mred-id) (debug-printf "controller-replace-current-widget: exit~n") ) (define/provide (controller-create-mred-id plugin [mred-parent (get-current-mred-id)]) (let* ([new-mred-id (send plugin new-mred-id mred-parent)]) (debug-printf "controller-create-mred-id: new-mred-id:~a~n" new-mred-id) (when new-mred-id (printf "controller-create-mred-id: creating widget from plugin ~a~n" (send plugin get-type)) (project-changed! new-mred-id) ; Call add-children wrapper for add-child - kdh 2012-02-29 (if mred-parent (send hierarchy-widget add-children new-mred-id) (send hierarchy-widget add-children new-mred-id #f)) ) (debug-printf "controller-replace-current-widget: exit~n") ; return: new-mred-id )) (define/provide (controller-delete-mred-id [mid (get-current-mred-id)]) (debug-printf "controller-delete-mred-id: mid:~a~n" mid) (when mid (let ([mid-parent (send mid get-mred-parent)]) (unless mid-parent (project-changed-save mid) ) (send mid delete) (project-changed! mid) (send hierarchy-widget delete-mred-id mid) (controller-select-mred-id mid-parent) ))) (define/provide (controller-move-up) (let* ([mid (get-current-mred-id)]) (debug-printf "controller-move-up:~n") (send mid move-up) (project-changed!) (send hierarchy-widget move-up) )) (define/provide (controller-move-down) (let* ([mid (get-current-mred-id)]) (debug-printf "controller-move-down:~n") (send mid move-down) (project-changed!) (send hierarchy-widget move-down) )) ; ************* ; * Templates * ; ************* ;; Loads the mred-id/widget hierarchy from the file ;; and place it under the current mred-id. ;; If any loaded id is already in use in the current hierarchy (project) ;; then it is changed to an unused name. ;; This function is not specific to templates, and is used also for projects ;; and copy/paste (which are in fact templates) (define (load-mred file parent-mid) (when file (debug-printf "load-mred: load file ~a~n" file) (begin-busy-cursor) (let* ([tlmid (and parent-mid (send parent-mid get-top-mred-parent))] [all-ids (if tlmid (map-send get-id (get-all-children tlmid)) '())] [all-ids-str (map ->string all-ids)] [mids (load-template file parent-mid)]) (end-busy-cursor) (debug-printf "load-mred: load done~n") (and mids (begin (when parent-mid ; we must change all the ids that are already in use ; (in the current hierarchy): (for-each (λ(m) (let* ([id (send m get-id)] [id-str (->string id)] ; Must use string because some symbols may be interned and some not! ; (because of gensym...) [id-exists? (member id-str all-ids-str)]) (when id-exists? (send m set-random-id)))) mids) ) ; create a hierarchy with these mred-ids: ; Call add-children wrapper for add-child - kdh 2012-02-29 (send hierarchy-widget add-children (first mids) (if parent-mid (send hierarchy-widget get-selected) #f)) (debug-printf "load-mred: exit~n") ; return value: mids ))) )) (define/provide (controller-load-template file [parent-mid (get-current-mred-id)]) (debug-printf "controller-load-template:~n") (when file (unless (load-mred file parent-mid) (printf "Error: cannot load template file ~a~n" file)))) (define/provide (controller-save-template name [file #f] [mid (get-current-mred-id)]) (debug-printf "controller-save-template: file:~a mid:~a~n" file mid) (when mid (save-template mid name file) (controller-update-templates) ) (debug-printf "controller-save-template: exit~n") ) (define/provide (controller-replace-current-template file) (debug-printf "controller-replace-current-template: file:~a~n" file) (save-template (get-current-mred-id) (get-template-name file) file) ;(controller-update-templates) (debug-printf "controller-replace-current-template: exit~n") ) (define/provide (controller-delete-template file) (debug-printf "controller-delete-template:~n") (delete-template file) (controller-update-templates) ) (define/provide (controller-update-templates) (make-template-dict) (toolbox-update-template-choices) ) ;; Copy/Cut/Paste a mred-id and its children (define/provide (controller-copy) (controller-save-template "Clipboard" (template-file "clipboard")) ) (define/provide (controller-cut) (controller-copy) (controller-delete-mred-id) (project-changed!) ) (define/provide (controller-paste) (controller-load-template (template-file "clipboard")) (project-changed!) ) (define/provide (controller-show/hide) (send (get-current-mred-id) show/hide)) ; ******************** ; * Saving & Loading * ; ******************** ; These functions are specific to the `project%' plugin, ; so it should probably not be here ! ; BAD! ; Depends on the property structure!! (define (set-project-changed project-mid val) (send (send (send project-mid get-property 'changed) get-prop) set-value val)) ;; Sets the 'changed' status of the top-level-mred-id (a project mred-id) to #t (define/provide (project-changed! [some-mid-child (get-current-mred-id)]) (set-project-changed (send some-mid-child get-top-mred-parent) #t)) (define/provide (controller-close-project [some-mild-child (get-current-mred-id)]) (debug-printf "controller-close-project:~n") (when some-mild-child (let ([mid (send some-mild-child get-top-mred-parent)]) (controller-delete-mred-id mid)))) ;; Asks for saving the project if it has changed since last save/load (define/provide (project-changed-save project-mid) (when (send project-mid get-property-value 'changed) (let ([save? (message-box "Save project?" (string-append* "Do you want to save the project " (send project-mid get-id) " before closing it?") #f '(yes-no caution))]) (when (equal? save? 'yes) (controller-save-project #f project-mid))))) (define/provide (controller-new-project) (let ([project-mid (controller-create-mred-id (get-widget-plugin 'project) #f)]) (set-project-changed project-mid #f) ; empty project are not "changed" (don't ask for saving it) )) ;; Loads the mred-id/widget hierarchy from the file ;; and place it at the top (no parent) ;; Simplified to return #t on success, #f otherwise - kdh 2012-02-29 (define/provide (load-project file) (debug-printf "load-project: ~a~n" file) (parameterize ([current-directory (path-only file)]) (let ([mids (load-mred file #f)]) (or (and mids (let ([proj-mid (first mids)]) (send (send (send proj-mid get-property 'file) get-prop) set-value (path->string file)) (set-project-changed proj-mid #f) (debug-printf "load-project: exit~n") ; Simplify return value - kdh 2012-02-29 ; return value: #t)) (and (printf "Error: cannot load project ~a~n" file) ; return value: #f))))) ; The controller has been compromised! ; There are GUI elements in the controller! ; Yurk! ... (Yes, I should clean that. Yes.) ;; Simplified to return #t on success, #f otherwise - kdh 2012-02-29 (define/provide (controller-load-project) (let ([file (get-file "Select a MrEd Designer Project File" #f #f #f "med" '() '(("MrEd Designer Project File" "*.med")) )]) ; Simplify return value - kdh 2012-02-29 (and file (load-project file)) )) (define/provide (save-project mid file) (debug-printf "save-project: enter~n") (begin-busy-cursor) (when mid (let ([project-mid (send mid get-top-mred-parent)]) (send (send (send project-mid get-property 'file) get-prop) set-value (path-string->string file)) (save-template project-mid (->string (send project-mid get-id)) file) ;(save-mred-id project-mid file) (set-project-changed project-mid #f) )) (end-busy-cursor) (debug-printf "save-project: exit~n") ; return value: #t ) (define/provide (controller-save-project [save-as? #f] [mid (get-current-mred-id)]) (when mid (let* ([project-mid (send mid get-top-mred-parent)] [file (or (and (not save-as?) (send project-mid get-property-value 'file)) ; or ask for file: (put-file "Select a file to save your MrEd Designer Project" toolbox-frame #f (symbol->string (send project-mid get-id)) "*.med" '() '(("MrEd Designer Project (.med)" "*.med")) ))] [file (and file (path-replace-suffix file ".med"))] ; [filestr (and file (->string file))] ; [filestr (if (and filestr (not (regexp-match "\\.med$" filestr))) ; (string-append filestr ".med") ; filestr)] ) (when file (save-project project-mid file)) ))) (define (choose-code-file dft-name [base-path #f] [parent-frame #f]) (let ([base-path (and base-path (normal-case-path (simple-form-path base-path)))] [file (put-file "Select the file to generate the code to" parent-frame base-path dft-name "*.ss" '() '(("Scheme (.ss)" "*.ss") ("Scheme (.scm)" "*.scm") ("Any" "*.*")))]) (and file (path->string file) ; (if base-path ; (let ([file (normal-case-path (simple-form-path file))] ; [relative (message-box "Relative or global path?" ; "Save file as relative to project path?" ; parent-frame ; '(yes-no))] ; ) ; (path->string ; (if (symbol=? 'yes relative) ; (find-relative-path base-path file) ; file))) ; (path->string file)) ))) (define/provide (controller-generate-code-to-console [mid (get-current-mred-id)]) (when mid (let ([project-mid (send mid get-top-mred-parent)]) (generate-module project-mid)))) (define/provide (controller-generate-code [mid (get-current-mred-id)] #:ask [ask-user? #t]) (when mid (let* ([project-mid (send mid get-top-mred-parent)] ;[proj-file (send project-mid get-property-value 'file)] [base-dir (send project-mid get-project-dir)]; (and proj-file (path-only (string->path proj-file)))] [dft-file (string-append (->string (send project-mid get-id)) ".ss")] [file (if ask-user? (choose-code-file dft-file base-dir toolbox-frame) dft-file)] ) (when file (parameterize ([current-directory (or base-dir (current-directory))]) (with-output-to-file file (λ()(generate-module project-mid)) #:exists 'replace) ) ))))