#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
         ;"properties.ss"
         "mred-id.ss"
         )


; This module makes the binding between the different frames and the model.

(define/provide (controller-exit-application)
  (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)
  (send property-frame show 
        (not (send property-frame is-shown?))))

(define/provide (controller-show-hierarchy-frame)
  (send hierarchy-frame show 
        (not (send hierarchy-frame is-shown?))))


(define/provide (controller-select-mred-id mid)
  (select-mred-id mid)
  (hierarchy-select mid)
  (update-property-frame mid)
  (update-toolbox-frame mid)
  )

(define/provide (controller-replace-current-widget)
  (send (get-current-mred-id) replace-widget)
  (send hierarchy-widget update-current-mred-id)
  )


(define/provide (controller-create-mred-id plugin [mred-parent (get-current-mred-id)])
  (let* ([new-mred-id (send plugin new-mred-id mred-parent)])
    (when new-mred-id
      ;     (printf "creating widget from plugin ~a~n" (send plugin get-type))
      (project-changed! new-mred-id)
      (if mred-parent
          (send hierarchy-widget add-child new-mred-id)
          (send hierarchy-widget add-child new-mred-id #f))
      )
    ; return:
    new-mred-id
    ))

(define/provide (controller-delete-mred-id [mid (get-current-mred-id)])
  (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)])
    (send mid move-up)
    (project-changed!)
    (send hierarchy-widget move-up)
    ))
  
(define/provide (controller-move-down)
  (let* ([mid (get-current-mred-id)])
    (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 alraedy 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
    (begin-busy-cursor)
    (debug-printf "loading file ~a\n" file)
    (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)
      (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:
             (send hierarchy-widget add-child (first mids)
                   (if parent-mid (send hierarchy-widget get-selected) #f))
             ; return value:
             mids
             )))
       ))
  
         
(define/provide (controller-load-template file [parent-mid (get-current-mred-id)])
  (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)])
  (when mid
    (save-template mid name file)
    (controller-update-templates)
    ))

(define/provide (controller-replace-current-template file)
  (save-template (get-current-mred-id) (get-template-name file) file)
  ;(controller-update-templates)
  )
  
(define/provide (controller-delete-template file)
  (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)])
  (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)
(define/provide (load-project 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)
              ; return value:
              proj-mid))
       (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.)

(define/provide (controller-load-project)
  ; SHOULD use get-file instead
  (let ([file (get-file "Select a MrEd Designer Project File"
                        #f #f #f "med" '()
                        '(("MrEd Designer Project File" "*.med"))
                        )])
    (and file
         (let ([proj-mid (load-project file)])
           proj-mid))
    ))

(define/provide (save-project mid file)
  (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)
      )))

(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"))
                               ))]
           [filestr (and file (->string file))]
           [filestr (if (and filestr (not (regexp-match "\\.med$" filestr)))
                     (string-append filestr ".med")
                     filestr)])
      (when filestr
        (save-project project-mid filestr))
      )))

(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)
          )
        ))))