;; -*- mode: Scheme; tab-width: 2; -*- ;;

(require-library
  lolevel data-structures ports srfi-42 srfi-69)

(module agar
  (agar-condition? make-agar-condition current-agar-condition check-agar-condition
   init-agar!
   pointer->object object->pointer pointer->class class->pointer
   object? make-object destroy-object! object-class object-name object-name-set!
   lookup-object object-first-child object-last-child object-next-sibling :object-child object-children
   class? lookup-class class-hierarchy class-version
   object-ref object-set! event-add!
   widget-expand! widget-position-set! widget-size-set!
   make-window window-caption window-caption-set! window-visible? window-visible-set!
   make-box make-button make-checkbox make-radio
   make-textbox textbox-string textbox-string-set!
   event-loop terminate!)
  (import
    scheme chicken foreign
    (only lolevel pointer? pointer=? tag-pointer tagged-pointer?)
    data-structures ports srfi-42 srfi-69)

(foreign-declare
  "#include <agar/core.h>"
  "#include <agar/gui.h>"
  "C_externexport void raise_fatal_condition(const char *msg);"
  "C_externexport void dispatch_event(AG_Event *evt);")

(define agar-condition?
  (conjoin
    (condition-predicate 'exn)
    (condition-predicate 'agar)))

(define condition-message
  (condition-property-accessor 'exn 'message))

(define (make-agar-condition msg)
  (make-composite-condition
    (make-property-condition 'exn 'message (or msg "Agar error"))
    (make-property-condition 'agar)))

(define-external (raise_fatal_condition [(const c-string) msg]) void
  (abort (make-agar-condition msg)))

(define current-agar-condition
  (case-lambda
    [()
     (cond
       [((foreign-lambda c-string "AG_GetError")) => make-agar-condition]
       [else #f])]
    [(v)
     (let ([msg
            (cond
              [(agar-condition? v) (condition-message v)]
              [else (call-with-output-string (cut print-error-message v <>))])])
       ((foreign-lambda* void ([nonnull-scheme-pointer msg] [int len])
          "AG_SetError(\"%.*s\", len, (const char *) msg);")
        msg (string-length msg)))]))

(define check-agar-condition
  (case-lambda
    [(v)
     (cond
       [(and (or (not v) (negative? v)) (current-agar-condition)) => signal]
       [else v])]
    [()
     (cond
       [(current-agar-condition) => signal])]))

(define (init-agar! #!key program verbose? create-datadir? soft-timers? graphics)
  (check-agar-condition
   ((foreign-safe-lambda int "AG_InitCore" nonnull-c-string unsigned-int)
    (or program (program-name))
    (bitwise-ior
      (if verbose? (foreign-value "AG_VERBOSE" unsigned-int) 0)
      (if create-datadir? (foreign-value "AG_CREATE_DATADIR" unsigned-int) 0)
      (if soft-timers? (foreign-value "AG_SOFT_TIMERS" unsigned-int) 0))))
  (when graphics
    (check-agar-condition
     ((foreign-safe-lambda int "AG_InitGraphics" c-string)
      (if (eq? graphics #t) #f graphics))))
  (void))

(define *object-tag* "AG_Object")
(define *class-tag* "AG_ObjectClass")

(define (pointer->object nonnull?)
  (if nonnull?
    (lambda (ptr)
      (ensure pointer? ptr)
      (tag-pointer ptr *object-tag*))
    (lambda (ptr)
      (and ptr (tag-pointer ptr *object-tag*)))))

(define (object->pointer nonnull?)
  (if nonnull?
    (lambda (obj)
      (ensure object? obj)
      obj)
    (lambda (obj)
      (ensure (disjoin not object?) obj)
      obj)))

(define (pointer->class nonnull?)
  (if nonnull?
    (lambda (ptr)
      (ensure pointer? ptr)
      (tag-pointer ptr *class-tag*))
    (lambda (ptr)
      (and ptr (tag-pointer ptr *class-tag*)))))

(define (class->pointer nonnull?)
  (if nonnull?
    (lambda (cls)
      (ensure class? cls)
      cls)
    (lambda (cls)
      (ensure (disjoin not class?) cls)
      cls)))

(define object?
  (case-lambda
    [(v)
     (tagged-pointer? v *object-tag*)]
    [(v class)
     (and
       (tagged-pointer? v *object-tag*)
       (tagged-pointer? class *class-tag*)
       (pointer=?
         ((foreign-lambda* c-pointer ([(nonnull-c-pointer "AG_Object") obj]) "C_return(obj->cls);") v)
         class))]))

(define (class? v)
  (tagged-pointer? v *class-tag*))

(include
  "agar-types.scm")

(define (make-object class #!key parent name)
  ((foreign-safe-lambda nonnull-object "AG_ObjectNew" object c-string nonnull-class)
   parent name class))

(define destroy-object!
  (foreign-safe-lambda void "AG_ObjectDestroy" nonnull-object))

(define object-class
  (foreign-lambda* nonnull-class ([nonnull-object obj]) "C_return(obj->cls);"))

(define-values (object-name object-name-set!)
  (let ([object-name
         (foreign-lambda* c-string ([nonnull-object obj]) "C_return(obj->name);")]
        [object-name-set!
         (foreign-safe-lambda void "AG_ObjectSetNameS" nonnull-object c-string)])
    (values
      (getter-with-setter object-name object-name-set!)
      object-name-set!)))

(define lookup-object
  (foreign-safe-lambda object "AG_ObjectFindS" nonnull-object nonnull-c-string))

(define object-first-child
  (foreign-lambda* object ([nonnull-object parent])
    "C_return(AG_TAILQ_FIRST(&AGOBJECT(parent)->children));"))

(define object-last-child
  (foreign-lambda* object ([nonnull-object parent])
    "C_return(AG_TAILQ_END(&AGOBJECT(parent)->children));"))

(define object-next-sibling
  (foreign-lambda* object ([nonnull-object obj])
    "C_return(AG_TAILQ_NEXT(AGOBJECT(obj), cobjs));"))

(define-syntax :object-child
  (syntax-rules ()
    [(:object-child cc child parent-expr)
     (:do cc
       (let ([parent parent-expr] [first #f] [last #f])
         (when parent
           (set! first (object-first-child parent)))
           (set! last (object-last-child parent)))
       ([child first])
       (not (equal? child last))
       (let ())
       #t
       ((object-next-sibling child)))]))

(define (object-children parent)
  (list-ec (:object-child child parent) child))

(define lookup-class
  (foreign-safe-lambda class "AG_LookupClass" nonnull-c-string))

(define class-hierarchy
  (foreign-lambda* c-string ([nonnull-class cls]) "C_return(cls->hier);"))

(define class-version
  (foreign-primitive ([nonnull-class cls])
    "C_word av[4] = { C_SCHEME_UNDEFINED, C_k, C_SCHEME_UNDEFINED, C_SCHEME_UNDEFINED };\n"
    "av[2] = C_fix(cls->ver.major);\n"
    "av[3] = C_fix(cls->ver.minor);\n"
    "C_values(4, av);\n"))

(define var-type
  (foreign-lambda* int ([(nonnull-c-pointer "AG_Variable") var])
    "C_return(var->type);"))

(foreign-declare "#include <agar/core/types.h>")

(define (var-ref var)
  (select (var-type var)
    [((foreign-value "AG_VARIABLE_NULL" int))
     #f]
    [((foreign-value "AG_VARIABLE_UINT" int))
     ((foreign-lambda* unsigned-int ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.u);")
      var)]
    [((foreign-value "AG_VARIABLE_P_UINT" int))
     ((foreign-lambda* unsigned-int ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Uint *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_INT" int))
     ((foreign-lambda* int ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.i);")
      var)]
    [((foreign-value "AG_VARIABLE_P_INT" int))
     ((foreign-lambda* int ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const int *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_UINT8" int))
     ((foreign-lambda* unsigned-byte ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.u8);")
      var)]
    [((foreign-value "AG_VARIABLE_P_UINT8" int))
     ((foreign-lambda* unsigned-byte ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Uint8 *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_SINT8" int))
     ((foreign-lambda* byte ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.s8);")
      var)]
    [((foreign-value "AG_VARIABLE_P_SINT8" int))
     ((foreign-lambda* byte ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Sint8 *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_UINT16" int))
     ((foreign-lambda* unsigned-short ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.u16);")
      var)]
    [((foreign-value "AG_VARIABLE_P_UINT16" int))
     ((foreign-lambda* unsigned-short ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Uint16 *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_SINT16" int))
     ((foreign-lambda* short ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.s16);")
      var)]
    [((foreign-value "AG_VARIABLE_P_SINT16" int))
     ((foreign-lambda* short ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Sint16 *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_UINT32" int))
     ((foreign-lambda* unsigned-integer32 ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.u32);")
      var)]
    [((foreign-value "AG_VARIABLE_P_UINT32" int))
     ((foreign-lambda* unsigned-integer32 ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Uint32 *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_SINT32" int))
     ((foreign-lambda* integer32 ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.s32);")
      var)]
    [((foreign-value "AG_VARIABLE_P_SINT32" int))
     ((foreign-lambda* integer32 ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Sint32 *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_UINT64" int))
     ((foreign-lambda* unsigned-integer64 ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.u64);")
      var)]
    [((foreign-value "AG_VARIABLE_P_UINT64" int))
     ((foreign-lambda* unsigned-integer64 ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Uint64 *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_SINT64" int))
     ((foreign-lambda* integer64 ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.s64);")
      var)]
    [((foreign-value "AG_VARIABLE_P_SINT64" int))
     ((foreign-lambda* integer64 ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const Sint64 *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_FLOAT" int))
     ((foreign-lambda* float ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.flt);")
      var)]
    [((foreign-value "AG_VARIABLE_P_FLOAT" int))
     ((foreign-lambda* float ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const float *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_DOUBLE" int))
     ((foreign-lambda* double ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.dbl);")
      var)]
    [((foreign-value "AG_VARIABLE_P_DOUBLE" int))
     ((foreign-lambda* double ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const double *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_STRING" int) (foreign-value "AG_VARIABLE_CONST_STRING" int))
     ((foreign-lambda* c-string ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.Cs);")
      var)]
    [((foreign-value "AG_VARIABLE_P_STRING" int) (foreign-value "AG_VARIABLE_P_CONST_STRING" int))
     ((foreign-lambda* c-string ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const char *const *)var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_POINTER" int) (foreign-value "AG_VARIABLE_CONST_POINTER" int))
     ((foreign-lambda* c-pointer ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(var->data.Cp);")
      var)]
    [((foreign-value "AG_VARIABLE_P_POINTER" int) (foreign-value "AG_VARIABLE_P_CONST_POINTER" int))
     ((foreign-lambda* c-pointer ([(nonnull-c-pointer "AG_Variable") var])
        "C_return(*(const void *const *)var->data.Cp);")
      var)]))

(define (var-set! var v)
  (select (var-type var)
    [((foreign-value "AG_VARIABLE_UINT" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-int v])
        "var->data.u = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_UINT" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-int v])
        "*(Uint *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_INT" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [int v])
        "var->data.i = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_INT" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [int v])
        "*(int *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_UINT8" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-byte v])
        "var->data.u8 = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_UINT8" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-byte v])
        "*(Uint8 *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_SINT8" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [byte v])
        "var->data.s8 = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_SINT8" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [byte v])
        "*(Sint8 *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_UINT16" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-short v])
        "var->data.u16 = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_UINT16" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-short v])
        "*(Uint16 *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_SINT16" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [short v])
        "var->data.s16 = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_SINT16" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [short v])
        "*(Sint16 *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_UINT32" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-integer32 v])
        "var->data.u32 = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_UINT32" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-integer32 v])
        "*(Uint32 *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_SINT32" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [integer32 v])
        "var->data.s32 = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_SINT32" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [integer32 v])
        "*(Sint32 *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_UINT64" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-integer64 v])
        "var->data.u64 = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_UINT64" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [unsigned-integer64 v])
        "*(Uint64 *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_SINT64" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [integer64 v])
        "var->data.s64 = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_SINT64" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [integer64 v])
        "*(Sint64 *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_FLOAT" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [float v])
        "var->data.flt = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_FLOAT" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [float v])
        "*(float *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_DOUBLE" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [double v])
        "var->data.dbl = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_DOUBLE" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [double v])
        "*(double *)var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_STRING" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [c-string v])
        "char *old = var->data.s;\n"
        "var->data.s = AG_Strdup(v);\n"
        "if (old) AG_Free(old);\n")
      var v)]
    [((foreign-value "AG_VARIABLE_P_STRING" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [c-string v])
        "char *old = *(char **)var->data.p;\n"
        "*(char **)var->data.p = AG_Strdup(v);\n"
        "if (old) AG_Free(old);\n")
      var v)]
    [((foreign-value "AG_VARIABLE_POINTER" int) (foreign-value "AG_VARIABLE_CONST_POINTER" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [c-pointer v])
        "var->data.p = v;")
      var v)]
    [((foreign-value "AG_VARIABLE_P_POINTER" int) (foreign-value "AG_VARIABLE_P_CONST_POINTER" int))
     ((foreign-lambda* void ([(nonnull-c-pointer "AG_Variable") var] [c-pointer v])
        "*(void **)var->data.p = v;")
      var v)]))

(define object-var
  (foreign-safe-lambda (c-pointer "AG_Variable") "AG_GetVariable" nonnull-object nonnull-c-string c-pointer))

(define-values (object-ref object-set!)
  (let ([object-ref
         (lambda (obj name)
           (cond
             [(object-var obj name #f) => var-ref]
             [else #f]))]
        [object-set!
         (lambda (obj name v)
           (cond
             [(object-var obj name #f) => (cut var-set! <> v)]
             [else (error 'object-ref "no such variable" name)]))])
    (values
      (getter-with-setter object-ref object-set!)
      object-set!)))

(define *event-handlers*
  (make-hash-table eqv? eqv?-hash))

(define arg-self
  (foreign-lambda* object ([(nonnull-c-pointer "AG_Event") event])
    "C_return(AG_SELF());"))
(define arg-sender
  (foreign-lambda* object ([(nonnull-c-pointer "AG_Event") event])
    "C_return(AG_SENDER());"))
(define arg-count
  (foreign-lambda* int ([(nonnull-c-pointer "AG_Event") event])
    "C_return(event->argc);"))
(define arg-ref
  (foreign-lambda* (c-pointer "AG_Variable") ([(nonnull-c-pointer "AG_Event") event] [int i])
    "C_return(&event->argv[i]);"))

(define-external (dispatch_event [(nonnull-c-pointer "AG_Event") event]) void
  (call-with-current-continuation
    (lambda (return)
      (with-exception-handler
        (lambda (exn)
          (current-agar-condition exn)
          (return))
        (lambda ()
          (apply
            (hash-table-ref *event-handlers* (var-ref (arg-ref event 1)))
            (arg-self event) (arg-sender event)
            (list-ec (:range i 2 (arg-count event))
              (var-ref (arg-ref event i)))))))))

(define (event-add! obj name handler)
  (let retry ([key (hash handler)])
    (if (hash-table-exists? *event-handlers* key)
      (retry (add1 key))
      (begin
        (hash-table-set! *event-handlers* key handler)
        ((foreign-safe-lambda* void ([nonnull-object obj] [nonnull-c-string name] [unsigned-int key])
           "AG_AddEvent(obj, name, dispatch_event, \"%u\", key);")
         obj name key)))))

(define (widget-expand! widget #!key hfill vfill expand)
  (cond
    [(or (and hfill vfill) expand)
     ((foreign-safe-lambda void "AG_Expand" nonnull-widget) widget)]
    [hfill
     ((foreign-safe-lambda void "AG_ExpandHoriz" nonnull-widget) widget)]
    [vfill
     ((foreign-safe-lambda void "AG_ExpandVert" nonnull-widget) widget)]))

(define widget-position-set!
  (foreign-safe-lambda void "AG_WidgetSetPosition" nonnull-widget int int))

(define widget-size-set!
  (foreign-safe-lambda void "AG_WidgetSetSize" nonnull-widget int int))

(define (make-window #!key name caption main?)
  (let ([win
         ((foreign-safe-lambda nonnull-window "AG_WindowNew" unsigned-int)
          (bitwise-ior
            (if main? (foreign-value "AG_WINDOW_MAIN" unsigned-int) 0)))])
    (when name
      (set! (object-name win) name))
    (when caption
      (set! (window-caption win) caption))
    win))

(define-values (window-caption window-caption-set!)
  (let ([window-caption
         (foreign-lambda* c-string ([nonnull-window win]) "C_return(win->caption);")]
        [window-caption-set!
         (foreign-safe-lambda void "AG_WindowSetCaptionS" nonnull-window c-string)])
    (values
      (getter-with-setter window-caption window-caption-set!)
      window-caption-set!)))

(define-values (window-visible? window-visible-set!)
  (let ([window-visible?
         (foreign-lambda bool "AG_WindowIsVisible" nonnull-window)]
        [window-visible-set!
         (lambda (win show?)
           ((if show?
              (foreign-safe-lambda void "AG_WindowShow" nonnull-window)
              (foreign-safe-lambda void "AG_WindowHide" nonnull-window))
            win))])
    (values
      (getter-with-setter window-visible? window-visible-set!)
      window-visible-set!)))

(define (make-box parent  #!key name label orient homogenous? padding spacing hfill? vfill? expand?)
  (let ([box
         ((foreign-safe-lambda nonnull-box "AG_BoxNew" widget int unsigned-int)
          parent
          (case orient
            [(horizontal horiz) (foreign-value "AG_BOX_HORIZ" int)]
            [(vertical vert) (foreign-value "AG_BOX_VERT" int)])
          (bitwise-ior
            (if homogenous? (foreign-value "AG_BOX_HOMOGENOUS" unsigned-int) 0)
            (if (or hfill? expand?) (foreign-value "AG_BOX_HFILL" unsigned-int) 0)
            (if (or vfill? expand?) (foreign-value "AG_BOX_VFILL" unsigned-int) 0)))])
    (when name
      (set! (object-name box) name))
    (when label
      ((foreign-safe-lambda void "AG_BoxSetLabelS" nonnull-box c-string)
       box label))
    (when padding
      ((foreign-safe-lambda void "AG_BoxSetPadding" nonnull-box int)
       box padding))
    (when spacing
      ((foreign-safe-lambda void "AG_BoxSetSpacing" nonnull-box int)
       box spacing))
    box))

(define (make-button parent #!key name label sticky? hfill? vfill? expand?)
  (let ([btn
         ((foreign-safe-lambda nonnull-widget "AG_ButtonNewS" widget unsigned-int c-string)
          parent
          (bitwise-ior
            (if sticky? (foreign-value "AG_BUTTON_STICKY" unsigned-int) 0)
            (if (or hfill? expand?) (foreign-value "AG_BUTTON_HFILL" unsigned-int) 0)
            (if (or vfill? expand?) (foreign-value "AG_BUTTON_VFILL" unsigned-int) 0))
          label)])
    (when name
      (set! (object-name btn) name))
    btn))

(define (make-checkbox parent #!key name label state hfill? vfill? expand?)
  (let ([chk
         ((foreign-safe-lambda nonnull-widget "AG_CheckboxNewS" widget unsigned-int c-string)
          parent
          (bitwise-ior
            (if state (foreign-value "AG_CHECKBOX_SET" unsigned-int) 0)
            (if (or hfill? expand?) (foreign-value "AG_CHECKBOX_HFILL" unsigned-int) 0)
            (if (or vfill? expand?) (foreign-value "AG_CHECKBOX_VFILL" unsigned-int) 0))
          label)])
    (when name
      (set! (object-name chk) name))
    chk))

(define (make-radio parent #!key name [items '()] hfill? vfill? expand?)
  (let ([rad
         ((foreign-safe-lambda nonnull-radio "AG_RadioNew" widget unsigned-int c-pointer)
          parent
          (bitwise-ior
            (if (or hfill? expand?) (foreign-value "AG_RADIO_HFILL" unsigned-int) 0)
            (if (or vfill? expand?) (foreign-value "AG_RADIO_VFILL" unsigned-int) 0))
          #f)])
    (when name
      (set! (object-name rad) name))
    (for-each
      (cut radio-item-add! rad <>)
      items)
    rad))

(define radio-items-clear!
  (foreign-safe-lambda void "AG_RadioClearItems" nonnull-radio))

(define radio-item-add!
  (foreign-safe-lambda void "AG_RadioAddItemS" nonnull-radio c-string))

(define (make-textbox parent #!key name label multiline? multilingual? password? int-only? flt-only? catch-tab? noemacs? nolatin1? nopopup? readonly? hfill? vfill? expand?)
  (let ([txt
         ((foreign-safe-lambda nonnull-textbox "AG_TextboxNewS" widget unsigned-int c-string)
          parent
          (bitwise-ior
            (if multiline? (foreign-value "AG_TEXTBOX_MULTILINE" unsigned-int) 0)
            (if multilingual? (foreign-value "AG_TEXTBOX_MULTILINGUAL" unsigned-int) 0)
            (if password? (foreign-value "AG_TEXTBOX_PASSWORD" unsigned-int) 0)
            (if int-only? (foreign-value "AG_TEXTBOX_INT_ONLY" unsigned-int) 0)
            (if flt-only? (foreign-value "AG_TEXTBOX_FLT_ONLY" unsigned-int) 0)
            (if catch-tab? (foreign-value "AG_TEXTBOX_CATCH_TAB" unsigned-int) 0)
            (if noemacs? (foreign-value "AG_TEXTBOX_NOEMACS" unsigned-int) 0)
            (if nolatin1? (foreign-value "AG_TEXTBOX_NOLATIN1" unsigned-int) 0)
            (if nopopup? (foreign-value "AG_TEXTBOX_NOPOPUP" unsigned-int) 0)
            (if readonly? (foreign-value "AG_TEXTBOX_READONLY" unsigned-int) 0)
            (if (or hfill? expand?) (foreign-value "AG_TEXTBOX_HFILL" unsigned-int) 0)
            (if (or vfill? expand?) (foreign-value "AG_TEXTBOX_VFILL" unsigned-int) 0))
          label)])
    (when name
      (set! (object-name txt) name))
    txt))

(define-values (textbox-string textbox-string-set!)
  (letrec ([textbox-copy-string
            (foreign-lambda size_t "AG_TextboxCopyString" nonnull-textbox scheme-pointer size_t)]
           [textbox-string
            (lambda (txt)
              (let* ([len (textbox-copy-string txt #f 0)]
                     [buf (make-string (add1 len))])
                (set! len (textbox-copy-string txt buf (string-length buf)))
                (substring buf 0 len)))]
           [textbox-string-set!
            (foreign-lambda void "AG_TextboxSetString" nonnull-textbox c-string)])
    (values
      (getter-with-setter textbox-string textbox-string-set!)
      textbox-string-set!)))

(define (event-loop)
  (check-agar-condition ((foreign-safe-lambda int "AG_EventLoop"))))

(define (terminate! #!optional v)
  ((foreign-safe-lambda void "AG_Terminate" int) (or v 0)))

(foreign-code
  "AG_SetFatalCallback(raise_fatal_condition);")

)

;; vim:set ft=scheme ts=2 sts=2 sw=2 ai: ;;