#lang scheme/gui

(require "code-write.ss"
         "properties.ss"
         "mreddesigner-misc.ss"
         )

(define/provide current-generate-code (make-parameter #f))

(define/provide mred-widget<%> (interface () ))

(define/provide (mred-widget%% c%)
  (class* c% (mred-widget<%>)
    (init-field mred-id)
    (getter mred-id)

    ; at the bottom, because f the dialog% widget that is blocking...
    (super-new)
    ))

;; The object holding a preview-widget (widgets that area created by the user).
;; If the widget values change, it must be recreated from scratch,
;; but the holder does not have to change (only its properties).
;; This makes things simpler.
(define/provide mred-id%
  (class (code-write%% object%)
    (super-new)
    (init-field 
     plugin
     mred-parent 
     properties
     [widget #f]
     )
    (field [mred-children '()]
           )
    
    (getter/setter widget properties plugin mred-parent)

    ; Tell our parent that we are its child
    (when mred-parent 
      (send mred-parent add-mred-child this))
    
    ;; Returns the mred-id% ancestor that has no mred-id parent.
    ;; (it may have a non-mred-id parent?)
    (define/public (get-top-level-mred-id)
      (if (is-a? mred-parent mred-id%)
          (send mred-parent get-top-level-mred-id)
          this))
    
    ;; Because of the plugin, we must redefine how arguments are printed
    (define/override (code-write-args)
      ;(printf "code-write-args: ~a\n" (get-id))
      ; now return the values needed
      (list (list 'plugin (list 'get-widget-plugin 
                                (list 'quote (send plugin get-type)))) 
            ; get-widget-plugin must then be reachable...
            (list 'mred-parent (code-write-value mred-parent))
            ; must handle hierarchical dependencies!
            (list 'properties (code-write-value properties))
            )
      )
    
    ;; Returns the property<%> corresponding to the given field-id
    (define/public (get-property field-id)
      (dict-ref properties field-id))
    
    ;; Returns the value of a given property
    (define/public (get-property-value field-id)
      (send (get-property field-id) get-value))
    
    (define/public (get-id) (get-property-value 'id))
    
    ;; Changes the id to put a random one based on the type of the plugin
    (define/public (set-random-id)
      (send (send (get-property 'id) get-prop) 
            set-value (send plugin get-random-id)))
            
    
    (define/public (is-type? t)
      (equal? t (get-property-value 'type)))

    
    (define/public (get-mred-children) (reverse mred-children))
    (define/public (add-mred-child w)
      (set! mred-children (cons w mred-children)))
    
    ;; WARNING!
    ;; Can only change simple props, not compound ones!
    (define/public (change-property-value field-id new-flat-val)
      (send (send (dict-ref properties field-id) get-prop)
            set-value new-flat-val))
    
    (define (create-widget parent [props properties])
      (set! widget (send plugin make-widget this parent props))
      (set! properties props)
      )
    
    (define (get-parent-widget)
      (and mred-parent
           (send mred-parent get-widget)))
    
    (define/public (can-change-child? child)
      (and (object-method-arity-includes? widget 'change-children 1)
           (member child (send widget get-children))
           ))
      
    ;; When the properties have changed,
    ;; The widget must be recreated from scratch
    (define/public (replace-widget)
      (recreate-top-level-window)
      ; The following could still be used:
;      (if (and mred-parent (send mred-parent can-change-child? this))
;          (let* ([old-widget widget]
;                 [parent (get-parent-widget)]
;                 [new-widget (recreate-widget-hierarchy parent)]
;                 )
;            (when parent
;              (send parent change-children
;                    (λ(l)
;                      (append-map (λ(x)(cond [(eq? x old-widget) (list new-widget)] ; replace
;                                             [(eq? x new-widget) '()] ; delete the new if present
;                                             [else (list x)]
;                                             ))
;                                  l))))
;            (when (is-a? old-widget top-level-window<%>)
;              (close-window old-widget))
;            ; recreer tous les enfants
;            ; en changeant le widget père
;            )
;          ; else, cannot change children, redraw the whole top-level-window:
;          (recreate-top-level-window)
;          )
      )
    
    (define/public (recreate-widget-hierarchy [parent (get-parent-widget)])
      (when (is-a? this area-container<%>)
        (send this begin-container-sequence))
      (set! widget (send plugin make-widget this parent properties))
      (for-each-send (recreate-widget-hierarchy widget) (get-mred-children))
      (when (is-a? this area-container<%>)
        (send this end-container-sequence))
      widget)
      
    (define/public (delete)
      (for-each-send delete (get-mred-children))
      (when (is-a? widget top-level-window<%>)
        (close-window widget))
      (when mred-parent 
        (send mred-parent delete-child this))
      (show #f)
      )
    
    (define/public (show s)
      (when (and widget (object-method-arity-includes? widget 'show 1))
        (send widget show s)))
    
    ; Returns the topmost mred-id of the current hierarchy (a project%)
    (define/public (get-top-mred-parent)
      (if mred-parent
          (send mred-parent get-top-mred-parent)
          this))
    
    ; returns the topmost WINDOW of the current hierarchy (a frame%, not a project%)
    (define/public (get-top-level-window-mred-id)
      (if (is-a? widget top-level-window<%>)
          this
          (and mred-parent
              (send mred-parent get-top-level-window-mred-id))
          ))
    
    ;; Needed when just replacing the current widget does not work:
    (define/public (recreate-top-level-window)
      (let ([tlw-mid (get-top-level-window-mred-id)])
        (when tlw-mid
          (close-window (send tlw-mid get-widget))
          (send tlw-mid recreate-widget-hierarchy)
          (send tlw-mid show #t)
          )))
    
    (define/public (delete-child mid)
      (set! mred-children (remq mid mred-children))
      (let ([midw (send mid get-widget)])
        (if (is-a? midw subwindow<%>)
            (send widget delete-child midw)
            (recreate-top-level-window))
        ))
    
    (define/public (move-up)
      (and mred-parent (send mred-parent move-up-child this)))
    (define/public (move-up-child mid-child)
      ; move-right because the list is reverse order
      (set! mred-children (list-move-right mred-children mid-child)) 
      (if (can-change-child? mid-child)
          (send widget change-children
                (λ(l)(list-move-left l (send mid-child get-widget))))
          (recreate-top-level-window)
        ))
           
    (define/public (move-down)
      (and mred-parent (send mred-parent move-down-child this)))
    (define/public (move-down-child mid-child)
      ; move-left because the list is reverse order
      (set! mred-children (list-move-left mred-children mid-child)) 
      (if (can-change-child? mid-child)
          (send widget change-children
                (λ(l)(list-move-right l (send mid-child get-widget))))
          (recreate-top-level-window)
          ))
    
    ;;; Code generation
           
    ;; Generate the options in the init-function
    (define/public (generate-options)
      (append-map (λ(p)(if (send (cdr p) get-no-code)
                           '()
                           (send (cdr p) generate-option (string-append* (get-id) "-"))))
                  properties))
    ;; Generate the setter in the init-function
    ;; (the define is made automatically)
    (define/public (generate-code)
      (parameterize ([current-generate-code #t])
        (let* ([parent-id (if mred-parent (send mred-parent get-id) #f)])
          `(set! ,(get-id)
                 (new ,(send plugin get-code-gen-class-symbol)
                      (parent ,parent-id)
                      ,@(append-map
                         (λ(p)(if (send (cdr p) get-no-code)
                                  '()
                                  (list (list (car p) 
                                              (send (cdr p) generate-code 
                                                    (string-append* (get-id) "-"))))))
                         properties)
                      ))
          )))

    ;; Finally, generate the widget:
    (create-widget (get-parent-widget))
    
    ))

;; Returns the list with w + all the children of w if w is a container.
(define/provide (get-all-children mid)
  (cons mid
        (append-map get-all-children
                    (send mid get-mred-children))))