;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; color (and other) styles
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; unique value
(define not-found cons(#nil #nil))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; decomposited style.
define new-style-obj(name)
  ;; contains known widgets.
  ;; key: widget name
  ;; value: widget properties (dictionary)
  define widget-props ::dict:new()
  ;; "defaults:" property contains yet another dictionary
  define widget-defaults ::dict:new()
  ;; common properties
  ;; key: property name
  ;; value: property value
  define commons ::dict:new()
  ;;
  define find-inherit(widget-name)
    define val
    define wdict ::dict:find(widget-props widget-name)
    if {dict? wdict}
      then
        {val := ::dict:find(wdict inherit:)}
        assert {{false? val} or {keyword? val}}
          string-append("invalid \"inherit\" property for widget \""
                        symbol->string(widget-name) "\"")
        val
      else
        #nil
  ;;
  method-lambda
    name: (self) name
    ;;
    %get-widget-props-dict: (self) widget-props
    %get-widget-defaults-dict: (self) widget-defaults
    %get-commons-dict: (self) commons
    ;;
    copy-from: (self other)
      define copy-dict(from to)
        define nd
        define it ::dict:iter:new(from)
        while ::dict:iter:next(it)
          cond
            {dict? ::dict:iter:value(it)}
              {nd := ::dict:new()}
              copy-dict ::dict:iter:value(it) nd
              ::dict:put! to ::dict:iter:key(it) nd
            else
              ::dict:put! to ::dict:iter:key(it) ::dict:iter:value(it)
      ;;
      define copy-nested-dict(from to)
        define it ::dict:iter:new(from)
        while ::dict:iter:next(it)
          ::dict:put! to ::dict:iter:key(it) ::dict:iter:value(it)
      ;;
      copy-dict other[%get-commons-dict:] commons
      copy-dict other[%get-widget-defaults-dict:] widget-defaults
      copy-dict other[%get-widget-props-dict:] widget-props
    ;;
    add-common-property: (self prop-name value)
      assert {keyword? prop-name} "invalid common property name"
      ;assert {not {void-object? value}} "property value cannot be #void"
      ::dict:put! commons prop-name value
      self
    ;;
    add-widget-property: (self widget-name prop-name value)
      assert {keyword? widget-name} "invalid widget name"
      assert {keyword? prop-name} "invalid widget property name"
      define wdict ::dict:find(widget-props widget-name)
      if {not {dict? wdict}}
        then
          {wdict := ::dict:new()}
          ::dict:put! widget-props widget-name wdict
      ::dict:put! wdict prop-name value
      self
    ;;
    add-widget-default-property: (self widget-name prop-name value)
      assert {keyword? widget-name} "invalid widget name"
      assert {keyword? prop-name} "invalid widget property name"
      define wdict ::dict:find(widget-defaults widget-name)
      if {not {dict? wdict}}
        then
          {wdict := ::dict:new()}
          ::dict:put! widget-defaults widget-name wdict
      ::dict:put! wdict prop-name value
      self
    ;;
    get-widget-property:
      case-lambda finders-keepers
        ;; return value or abort
        (self widget-name prop-name)
          define res finders-keepers(self widget-name prop-name not-found)
          assert {not {res eq? not-found}}
            string-append("widget \"" symbol->string(widget-name)
                          "\" doesn't have properpy \"" symbol->string(prop-name) "\"")
        ;; return value or default
        (self widget-name prop-name default)
          assert {keyword? widget-name} "invalid widget name"
          assert {keyword? prop-name} "invalid widget property name"
          ;define it ::dict:iter:new(widget-props)
          ;while ::dict:iter:next(it)
          ;  printf "key=%o; value=%o\n" ::dict:iter:key(it) ::dict:iter:value(it)
          define res
          define wdict ::dict:find(widget-props widget-name)
          if {not {dict? wdict}}
            {res := ::dict:find-nf(commons prop-name default)}
            if {{res := ::dict:find-nf(wdict prop-name not-found)} eq? not-found}
              if {keyword? {res := find-inherit(widget-name)}}
                {res := self[get-widget-property: res prop-name default]}
                {res := ::dict:find-nf(commons prop-name default)}
          res
    ;;
    setup-widget-defaults: (self widget widget-name ignore-dict)
      assert {keyword? widget-name} "invalid widget name"
      ;; first process inherited defaults
      define inh find-inherit(widget-name)
      if {symbol? inh}
        self[setup-widget-defaults: widget inh ignore-dict]
      ;printf "swd: wname=%o\n" widget-name
      ;; now process widget defaults
      define res ::dict:find(widget-defaults widget-name)
      cond
        {dict? res}
          define val
          define it ::dict:iter:new(res)
          while ::dict:iter:next(it)
            if {{null? ignore-dict} or
                {::dict:find-nf(ignore-dict ::dict:iter:key(it) not-found) eq? not-found}}
              then
                {val := ::dict:iter:value(it)}
                if {procedure? val}
                  {val := val(widget)}
                ;printf "  swd: wname=%o; key=%o; value=%o\n" widget-name ::dict:iter:key(it) val
                if {not widget[handle-property: ::dict:iter:key(it) val]}
                  error string-append("invalid default property \""
                                      symbol->string(::dict:iter:key(it))
                                      "\" for widget \""
                                      symbol->string(widget-name)
                                      "\"")
        else #void
      self


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define styles ::dict:new())

define register-style(name ... list)
  assert {symbol? name} "invalid style name"
  define sob ::dict:find(styles name)
  if {not {procedure? sob}}
    then
      {sob := new-style-obj(name)}
      ::dict:put! styles name sob
  ;;
  define copy-style(xname)
    assert {symbol? xname} "style name to copy should be a symbol"
    define stl ::dict:find(styles xname)
    assert {procedure? stl} string-append("cannot copy unknown style \"" symbol->string(xname) "\"")
    sob[copy-from: stl]
  ;;
  define parse-widget(list)
    define wname car(list)
    ;;
    define parse-defaults(list)
      while {not-null? list}
        sob[add-widget-default-property: wname caar(list) cadar(list)]
        {list := cdr(list)}
    ;;
    assert {keyword? wname} "bad widget name"
    {list := cdr(list)}
    while {not-null? list}
      cond
        {caar(list) eq? defaults:}
          parse-defaults(cdar(list))
        else
          sob[add-widget-property: wname caar(list) cadar(list)]
      {list := cdr(list)}
  ;;
  ;printf "name=%o; list=%o\n" name list
  ;printf "name=%o; list=%o\n" name list
  if {lax-caar(list) eq? base-style:}
    then
      copy-style(cadar(list))
      {list := cdr(list)}
  while {not {null? list}}
    cond
      {caar(list) eq? widget:}
        parse-widget(cdar(list))
      else
        sob[add-common-property: caar(list) cadar(list)]
    {list := cdr(list)}
