\ snd-xm.fs -- snd-motif|gtk.scm|snd-xm.rb --> snd-xm.fs

\ Author: Michael Scholz <mi-scholz@users.sourceforge.net>
\ Created: Mon Dec 26 22:36:46 CET 2005
\ Changed: Sat Jul 30 18:31:36 CEST 2011

\ Commentary:
\
\ Requires --with-motif|gtk and module libxm.so|libxg.so or --with-static-xm|xg!
\
\ Tested with Snd 12.x
\             Fth 1.2.x
\             Motif 2.3.0 X11R6
\             Gtk+ 3.0.11, Glib 2.28.8, Pango 1.28.4, Cairo 1.10.2
\ 
\ Motif and Gtk:
\
\ widget?                  ( w -- f )
\ set-sensitive            ( w f -- )
\ is-managed?              ( w -- f )
\ change-label     	   ( widget new-label -- )
\ for-each-child   	   ( widget prc -- )
\ load-font                ( name -- fid|#f )
\ host-name                ( -- host )
\ add-main-pane            ( name class args -- wid )
\ white-pixel      	   ( -- pix )
\ black-pixel      	   ( -- pix )
\ raise-dialog             ( dialog -- )
\ activate-dialog          ( dialog -- )
\ show-disk-space          ( snd -- )
\
\ Motif only:
\ 
\ main-dpy                 ( -- dpy )
\ current-screen   	   ( -- scr )
\ screen-depth     	   ( -- n )
\ 
\ children->array          ( widget -- array )
\ find-child               ( widget name -- wid )
\ widget-exists?           ( widget name -- f )
\ main-widget-exists?      ( name -- f )
\ display-widget-tree      ( widget -- )
\ set-main-color-of-widget ( w -- )
\ 
\ add-channel-pane         ( snd chn name type args -- wid )
\ add-sound-pane           ( snd name type args -- wid )
\ add-listener-pane        ( name type args -- wid )
\ 
\ add-mark-pane            ( -- )
\ 
\ current-label    	   ( widget -- label )

\ Code:

'snd-nogui provided? [if] skip-file [then]

$" X error" create-exception x-error

\ if not configured --with-static-xm|g
'snd-motif provided? 'xm provided? not && [if] dl-load libxm Init_libxm [then]
'snd-gtk   provided? 'xg provided? not && [if] dl-load libxg Init_libxg [then]

require extensions

\ ;;; -------- show-disk-space
\ ;;;
\ ;;; adds a label to the minibuffer area showing the current free space 

hide
#() value labelled-snds

: kmg { num -- str }
  num 0<= if
    $" disk full!"
  else
    "" { str }
    num 1024 d> if
      num 1024 1024 * d> if
	$" space: %6.3fG" #( num 1024.0 1024.0 f* f/ ) string-format
      else
	$" space: %6.3fM" #( num 1024.0 f/ )           string-format
      then
    else
      $" space: %10dK" #( num ) string-format
    then ( str )
  then
;
set-current

#f value showing-disk-space		\ for prefs
\
\ after-open-hook <'> show-disk-space add-hook!
\
previous

\ ===== Gtk and Motif =====

'snd-gtk provided? [if]
  : widget?       ( w -- f ) FGTK_IS_WIDGET ;
  : set-sensitive ( w f -- ) Fgtk_widget_set_sensitive drop ;

  [undefined] Fgtk_widget_get_realized [if]
    <'> noop alias is-managed? ( wid -- f )
  [else]
    <'> Fgtk_widget_get_realized alias is-managed? ( wid -- f )
  [then]

  : change-label ( wid new-label -- )
    doc" Changes WIDGET's label to be NEW-LABEL."
    { wid new-label }
    wid if
      wid FGTK_IS_LABEL if
	wid
      else
	wid FGTK_BIN Fgtk_bin_get_child
      then FGTK_LABEL new-label Fgtk_label_set_text drop
    then
  ;

  hide
  : for-each-cb ( cb -- prc; w d self -- val )
    2 proc-create swap , ( prc )
   does> { w d self -- val }
    self @ ( cb ) #( w ) run-proc
  ;
  set-current

  : for-each-child { wid prc -- }
    doc" Applies PRC ( w -- val ) to WIDGET and each of its children."
    wid widget? if
      prc #( wid ) run-proc drop
      wid FGTK_CONTAINER prc for-each-cb Fgtk_container_foreach drop
    then
  ;
  previous

  : load-font ( name -- fid|#f ) Fpango_font_description_from_string ;

  : host-name ( -- host )
    doc" Returns name of current machine."
    main-widgets 0 array-ref
    "WM_CLIENT_MACHINE" #f Fgdk_atom_intern
    FGDK_TARGET_STRING 0 1024 0 Fgdk_property_get { val }
    \ we get '( #t #( GdkAtom 0x3f ) 8 21 "pumpkin.fth-devel.net" )
    val car if
      val 4 list-ref 0 val 3 list-ref string-substring
    else
      #f
    then
  ;

  \ --- add our own pane to the overall Snd window (underneath the listener in this case) ---

  \ main-widgets 5 array-ref (without -notebook) and
  \ main-widgets 2 array-ref
  \ seem to be of type GTK_BOX [ms]

  : add-main-pane <{ name :optional class-not-needed #f args-not-needed #f -- wid }>
    FGTK_ORIENTATION_HORIZONTAL 0 Fgtk_box_new { pane }
    main-widgets 5 array-ref { parent }
    parent FGTK_IS_BOX unless main-widgets 2 array-ref to parent then
    parent FGTK_IS_BOX unless
      'x-error $" %s: no GTK_BOX widget found" #( get-func-name ) fth-raise
    then
    parent FGTK_BOX pane #f #f 4 Fgtk_box_pack_start drop
    pane Fgtk_widget_show drop
    pane name Fgtk_widget_set_name drop
    pane
  ;

  : get-color-pixel ( name -- pix )
    { name }
    FGdkColor { tmp }
    name tmp Fgdk_color_parse drop
    tmp Fgdk_color_copy
  ;

  : white-pixel ( -- pix ) "white" get-color-pixel ;
  : black-pixel ( -- pix ) "black" get-color-pixel ;

  \ --- bring possibly-obscured dialog to top ---

  : raise-dialog ( dialog -- )
    { w }
    w Fgtk_widget_show drop
    w FGTK_WINDOW Fgtk_window_present drop
  ;

  <'> raise-dialog alias activate-dialog ( dialog -- )

  \ --- show-disk-space, Gtk specific ---

  hide
  : show-label <{ data -- n }>
    data 0 array-ref sound? if
      data 0 array-ref { snd }
      data 1 array-ref { wid }
      snd file-name disk-kspace kmg { space }
      wid FGTK_LABEL space Fgtk_label_set_text drop
      10000 running-word data Fg_timeout_add drop
      0
    else
      nil
    then
  ;
  set-current

  : show-disk-space <{ snd -- }>
    doc" Adds a label to the minibuffer area showing the current free space \
    (for use with after-open-hook)."
    #f ( flag )
    labelled-snds each { n } n 0 array-ref snd equal? if
	( flag ) drop
	n
	leave
      then
    end-each { previous-label }
    previous-label unless
      snd sound? if
	#t to showing-disk-space
	snd sound-widgets 10 array-ref { name-form }
	snd file-name disk-kspace kmg { space }
	space Fgtk_label_new { new-label }
	name-form FGTK_BOX new-label #f #f 6 Fgtk_box_pack_start drop
	new-label Fgtk_widget_show drop
	#( snd new-label ) to previous-label
	labelled-snds previous-label array-push drop
	10000 <'> show-label previous-label Fg_timeout_add drop
      else
	$" no sound found for disk space label" snd-error drop
      then
    then
  ;
  previous
[else]					\ Motif
  : widget?       ( w -- f)  FWidget? ;
  : set-sensitive ( w f -- ) FXtSetSensitive drop ;

  <'> FXtIsManaged alias is-managed? ( wid -- f )

  : change-label ( wid new-label -- )
    doc" Changes WIDGET's label to be NEW-LABEL."
    { wid new-label }
    new-label FXmStringCreateLocalized { str }
    wid #( FXmNlabelString str ) FXtVaSetValues drop
    str FXmStringFree drop
  ;

  : for-each-child { wid prc -- }
    doc" Applies PRC to WIDGET and each of its children."
    prc #( wid ) run-proc drop
    wid FXtIsComposite if
      wid #( FXmNchildren 0 ) FXtVaGetValues 1 array-ref each ( w ) prc recurse end-each
    then
  ;

  : main-dpy ( -- dpy ) main-widgets 1 array-ref FXtDisplay ;

  : load-font ( name -- fid|#f )
    { name }
    main-dpy name FXLoadQueryFont { fs }
    fs FXFontStruct? if fs Ffid else #f then 
  ;

  : current-screen ( -- scr )
    doc" Returns the current X screen number of the current display."
    main-dpy FDefaultScreenOfDisplay
  ;

  : white-pixel  ( -- pix ) current-screen FWhitePixelOfScreen ;
  : black-pixel  ( -- pix ) current-screen FBlackPixelOfScreen ;
  : screen-depth ( -- n )   current-screen FDefaultDepthOfScreen ;

  \ --- apply func to every widget belonging to w ---

  hide
  : children->array-cb ( ary -- xt; child self -- )
    1 proc-create swap ,
   does> ( child self -- )
    ( self ) @ swap ( child ) array-push drop
  ;
  set-current

  : children->array ( widget -- array )
    #() { ary }
    ( widget ) ary children->array-cb for-each-child
    ary
  ;
  previous
  
  : find-child ( widget name -- wid )
    doc" Returns a widget named NAME, if one can be found in the widget hierarchy beneath WIDGET."
    { widget name }
    #f
    widget children->array each { w }
      w FXtName name string= if
	not
	w swap
	leave
      then
    end-each
    unless 'no-such-widget #( get-func-name name ) fth-throw then
  ;

  : widget-exists? { widget name -- f }
    #f ( flag ) widget children->array each ( w ) FXtName name string= if not leave then end-each
  ;

  : main-widget-exists? ( name -- f ) main-widgets 1 array-ref swap widget-exists? ;

  hide
  : display-widget <{ widget n -- }>
    widget FXtName empty? if
      "<unnamed>"
    else
      widget FXtName
    then
    n spaces .string cr
    widget FXtIsComposite if
      widget #( FXmNchildren 0 ) FXtVaGetValues 1 array-ref each ( w ) n 2 + recurse end-each
    then
  ;
  set-current

  : display-widget-tree { widget -- }
    doc" Displays the hierarchy of widgets beneath WIDGET."
    <'> display-widget #( widget 0 ) run-proc drop
  ;
  previous

  hide
  : change-color-cb <{ w -- }>
    w FXtIsWidget if
      w FXmIsScrollBar if
	w position-color FXmChangeColor drop
      else
	w basic-color FXmChangeColor drop
      then
    then
  ;
  set-current

  : set-main-color-of-widget ( widget -- )
    doc" Sets the background color of WIDGET."
    <'> change-color-cb for-each-child
  ;
  previous

  : host-name ( -- host )
    doc" Returns name of current machine."
    main-widgets 1 array-ref { wid }
    wid FXtWindow { win }
    main-dpy win main-dpy "WM_CLIENT_MACHINE" #f FXInternAtom 0 32 #f FXA_STRING
    FXGetWindowProperty { host }
    host if host 5 array-ref else host then
  ;
  
  \ --- add our own pane to the channel section ---
  \ 
  \ 0 0 "new-pane" FxmDrawingAreaWidgetClass
  \ #( FXmNbackground graph-color FXmNforeground data-color ) add-channel-pane value draw-widget

  : add-channel-pane { snd chn name typ args -- wid }
    name typ snd chn channel-widgets 7 array-ref FXtParent FXtParent args FXtCreateManagedWidget
  ;

  \ --- add our own pane to the sound section (underneath the controls in this case) ---

  : add-sound-pane { snd name typ args -- wid }
    name typ snd sound-widgets 0 array-ref args undef FXtCreateManagedWidget
  ;

  \ --- add our own pane to the overall Snd window (underneath the listener in this case) ---

  : add-main-pane { name class args -- wid }
    main-widgets 5 array-ref dup unless drop main-widgets 3 array-ref then { parent }
    name class parent args undef FXtCreateManagedWidget
  ;

  \ --- add a widget at the top of the listener ---

  : add-listener-pane { name typ args -- wid }
    main-widgets 1 array-ref "lisp-listener" find-child { listener }
    listener FXtParent { listener-scroll }
    listener-scroll FXtParent { listener-form }
    listener-scroll FXtUnmanageChild drop
    args
    #( FXmNleftAttachment  FXmATTACH_FORM
       FXmNrightAttachment FXmATTACH_FORM
       FXmNtopAttachment   FXmATTACH_FORM ) array-append to args
    name typ listener-form args undef FXtCreateManagedWidget { top-widget }
    listener-scroll
    #( FXmNtopAttachment FXmATTACH_WIDGET FXmNtopWidget top-widget ) FXtVaSetValues drop
    listener-scroll FXtManageChild drop
    top-widget
  ;

  \ --- bring possibly-obscured dialog to top ---

  : raise-dialog ( dialog -- )
    { w }
    w FWidget? if
      w FXtIsManaged if
	w FXtParent { parent }
	parent FWidget? if
	  parent FxmDialogShellWidgetClass FXtIsSubclass if
	    parent FXtGrabNone FXtPopup drop
	  then
	then
      then
    then
  ;

  : activate-dialog ( dialog -- ) dup FXtIsManaged if raise-dialog else FXtManageChild drop then ;

  \ --- add-mark-pane ---

  #f value including-mark-pane

  hide
  #() value mark-list-lengths
  #() value mark-lists

  : find-mark-list { snd chn dats -- lst }
    #f					\ flag
    dats each { dat }
      snd dat 0 array-ref =
      chn dat 1 array-ref = && if
	drop				\ drop flag
	dat 2 array-ref
	leave
      then
    end-each
  ;

  : mark-list-length ( snd chn -- len ) mark-list-lengths find-mark-list dup unless drop 0 then ;

  : set-mark-list-length { snd chn len -- }
    mark-list-lengths each { dat }
      snd dat 0 array-ref =
      chn dat 1 array-ref = && if
	mark-list-lengths i array-delete! drop
	leave
      then
    end-each
    mark-list-lengths #( snd chn len ) array-push drop
  ;

  : mark-list ( snd chn -- lst ) mark-lists find-mark-list dup if 2 array-ref else drop #() then ;

  : set-mark-list { snd chn lst -- } mark-lists #( snd chn lst ) array-push drop ;

  : deactivate-channel { snd chn -- }
    snd chn mark-list-length 0>
    snd chn mark-list FWidget? && if
      snd chn mark-list #( FXmNchildren 0 ) FXtVaGetValues 1 array-ref each
	FXtUnmanageChild drop
      end-each
    then
  ;

  : marks-focus-cb        <{ w c i -- f }> w #( FXmNbackground white-pixel ) FXtVaSetValues ;
  : marks-losing-focus-cb <{ w c i -- f }> w #( FXmNbackground basic-color ) FXtVaSetValues ;

  : marks-activate-cb <{ w c info -- }>
    w #( FXmNuserData 0 ) FXtVaGetValues 1 array-ref { id }
    w #( FXmNvalue 0 )    FXtVaGetValues 1 array-ref { txt }
    txt string? txt length 0> && if txt string->number else #f then { samp }
    samp if id samp set-mark-sample else id delete-mark then drop
    w #( FXmNbackground basic-color ) FXtVaSetValues drop
  ;

  : marks-enter-cb <{ w c i f -- f }> mouse-enter-text-hook #( w ) run-hook ;
  : marks-leave-cb <{ w c i f -- f }> mouse-leave-text-hook #( w ) run-hook ;

  : make-mark-list { snd chn -- }
    snd chn mark-list-length { cur-len }
    snd chn deactivate-channel
    snd chn mark-list FWidget? unless
      snd chn "mark-box" FxmFormWidgetClass
      #( FXmNbackground       basic-color
	 FXmNorientation      FXmVERTICAL
	 FXmNpaneMinimum      100
	 FXmNbottomAttachment FXmATTACH_FORM ) add-channel-pane { mark-box }
      "Marks" FxmLabelWidgetClass mark-box
      #( FXmNbackground       highlight-color
	 FXmNleftAttachment   FXmATTACH_FORM
	 FXmNrightAttachment  FXmATTACH_FORM
	 FXmNalignment        FXmALIGNMENT_CENTER
	 FXmNtopAttachment    FXmATTACH_FORM ) undef FXtCreateManagedWidget { mark-label }
      "mark-scroller" FxmScrolledWindowWidgetClass mark-box
      #( FXmNbackground       basic-color
	 FXmNscrollingPolicy  FXmAUTOMATIC
	 FXmNscrollBarDisplayPolicy FXmSTATIC
	 FXmNleftAttachment   FXmATTACH_FORM
	 FXmNrightAttachment  FXmATTACH_FORM
	 FXmNtopAttachment    FXmATTACH_WIDGET
	 FXmNtopWidget        mark-label
	 FXmNbottomAttachment FXmATTACH_FORM ) undef FXtCreateManagedWidget { mark-scroller }
      "mark-list" FxmRowColumnWidgetClass mark-scroller
      #( FXmNorientation      FXmVERTICAL
	 FXmNtopAttachment    FXmATTACH_FORM
	 FXmNbottomAttachment FXmATTACH_FORM
	 FXmNspacing          0 ) undef FXtCreateManagedWidget { mlist }
      mark-scroller set-main-color-of-widget
      mark-box #( FXmNpaneMinimum 1 ) FXtVaSetValues drop
      snd chn #( snd chn mlist ) set-mark-list
    then
    snd chn #f marks { new-marks }
    new-marks length cur-len > if
      snd chn mark-list { lst }
      new-marks length cur-len ?do
	"field" FxmTextFieldWidgetClass lst
	#( FXmNbackground basic-color ) undef FXtCreateWidget { tf }
	tf FXmNfocusCallback       <'> marks-focus-cb        undef FXtAddCallback drop
	tf FXmNlosingFocusCallback <'> marks-losing-focus-cb undef FXtAddCallback drop
	tf FXmNactivateCallback    <'> marks-activate-cb     undef FXtAddCallback drop
	tf FEnterWindowMask #f     <'> marks-enter-cb        undef FXtAddEventHandler drop
	tf FLeaveWindowMask #f     <'> marks-leave-cb        undef FXtAddEventHandler drop
      loop
    then
    snd chn new-marks length set-mark-list-length
    snd chn mark-list #( FXmNchildren 0 ) FXtVaGetValues 1 array-ref each { wid }
      new-marks empty? ?leave
      wid FXmIsTextField if
	wid
	#( FXmNvalue    new-marks 0 array-ref undef mark-sample number->string
	   FXmNuserData new-marks 0 array-ref ) FXtVaSetValues drop
	wid FXtManageChild drop
	new-marks array-shift to new-marks
      then
    end-each
    #f
  ;

  : remark <{ id snd chn reason -- }> snd chn make-mark-list ;
  : unremark <{ snd -- }> snd channels 0 ?do snd i deactivate-channel loop ;

  : marks-edit-cb { snd chn -- proc; self -- }
    0 proc-create chn , snd ,
   does> ( self -- )
    { self }
    self @ { chn }
    self cell+ @ { snd }
    snd chn mark-list FWidget? if snd chn make-mark-list then
  ;

  : open-remarks <{ snd -- }>
    snd channels 0 ?do
      snd i after-edit-hook snd i marks-edit-cb add-hook!
      snd i undo-hook       snd i marks-edit-cb add-hook!
    loop
  ;

  : marks-update-proc <{ snd -- }> snd channels 0 ?do snd i make-mark-list loop ;
  : marks-update-cb <{ snd -- proc }> snd <'> marks-update-proc ;
  set-current

  : add-mark-pane ( -- )
    #t to including-mark-pane
    mark-hook       <'> remark          add-hook!
    close-hook      <'> unremark        add-hook!
    after-open-hook <'> open-remarks    add-hook!
    update-hook     <'> marks-update-cb add-hook!
  ;
  previous

  \ --- show-disk-space, Motif specific ---

  hide
  : show-label <{ data id -- }>
    data 0 array-ref empty? unless
      data 0 array-ref { snd }
      data 1 array-ref { wid }
      data 2 array-ref { app }
      snd sound? if wid  snd file-name disk-kspace kmg change-label then
      app 10000 running-word data FXtAppAddTimeOut drop
    then
  ;
  set-current

  : show-disk-space <{ snd -- }>
    doc" Adds a label to the minibuffer area showing the current free space \
    (for use with after-open-hook)."
    #f ( flag )
    labelled-snds each { n } n 0 array-ref snd equal? if
	( flag ) drop
	n
	leave
      then
    end-each { previous-label }
    previous-label unless
      snd sound? if
	#t to showing-disk-space
	main-widgets 0 array-ref { app }
	snd sound-widgets { widgets }
	widgets 3 array-ref { minibuffer }
	widgets 6 array-ref { unite-button }
	widgets 9 array-ref { sync-button }
	minibuffer FXtParent { name-form }
	snd file-name disk-kspace kmg FXmStringCreateLocalized { str }
	minibuffer FXtUnmanageChild drop
	minibuffer #( FXmNrightAttachment FXmATTACH_NONE ) FXtVaSetValues drop
	"space" FxmLabelWidgetClass name-form
	#( FXmNbackground      basic-color
	   FXmNleftAttachment  FXmATTACH_NONE
	   FXmNlabelString     str
	   FXmNrightAttachment FXmATTACH_WIDGET
	   FXmNrightWidget     unite-button FXtIsManaged if unite-button else sync-button then
	   FXmNtopAttachment   FXmATTACH_FORM ) undef FXtCreateManagedWidget { new-label }
	minibuffer
	#( FXmNrightWidget new-label FXmNrightAttachment FXmATTACH_WIDGET ) FXtVaSetValues drop
	minibuffer FXtManageChild drop
	str FXmStringFree drop
	#( snd new-label app ) to previous-label
	labelled-snds previous-label array-push drop
	app 10000 <'> show-label previous-label FXtAppAddTimeOut drop
      else
	$" no sound found for disk space label" snd-error drop
      then
    then
  ;
  previous

  : current-label ( widget -- label )
    doc" Returns WIDGET's label."
    ( wid ) #( FXmNlabelString 0 ) FXtVaGetValues 1 array-ref { xmstr }
    xmstr #f FXmCHARSET_TEXT FXmCHARSET_TEXT #f 0 FXmOUTPUT_ALL FXmStringUnparse
  ;
[then]

\ snd-xm.fs ends here
