Paste: piano-roll attempt 2

! Copyright (C) 2024 modula t. worm.
! See https://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs colors combinators f-patterns fonts
formatting io kernel make math math.order models namespaces
opengl prettyprint random sequences ui ui.gadgets
ui.gadgets.scrollers ui.gestures ui.pens.solid ui.render ui.text
ui.tools.inspector ui.tools.listener ;
IN: piano-roll

SYMBOL: listener

listener [ get-listener ] initialize

: listener-output-stream ( -- stream )
    listener get [ listener-streams nip ] [ f ] if* ;

: listener-print ( string -- )
    listener-output-stream [ print ] with-output-stream ;

: listener-. ( object -- )
    listener-output-stream [ . ] with-output-stream ;

TUPLE: piano-roll < model
    { events sequence initial: { } } ;

: event-beat ( event -- beat )
    "beat" swap at 0 or ;

SYMBOL: piano-roll-model

: <piano-roll> ( -- model )
    { } piano-roll new-model dup piano-roll-model set-global ;

PREDICATE: integer>=0 < integer 0 >= ; ! FIX: will assert-non-negative work instead?

TUPLE: piano-roll-gadget < gadget
    { beat-width integer>=0 initial: 100 }
    { event-height integer>=0 initial: 25 } ;

SYMBOL: current-piano-roll-gadget

SYMBOL: current-gadget

: beat-width ( -- width )
    current-gadget get [ beat-width>> ] [ 100 ] if* ;

: pitch-height ( -- height ) ! height of a normal event
    25 ;

: event-width ( event -- width )
    event-dur beat-width * ;

: event-height ( event -- height )
    drop current-gadget get [ event-height>> ] [ pitch-height ] if* ;

: event-x-pos ( event -- x )
    event-beat beat-width * ;

: event-y-pos ( event -- y )
    drop 0 ! ???
    ;

: event-pos ( event -- pos )
    [ event-x-pos ] [ event-y-pos ] bi 2array ;

: event-dim ( event -- dim )
    [ event-dur beat-width * ]
    [ event-height ] bi 2array ;

: draw-event-rect ( event -- )
    COLOR: red gl-color
    [ event-pos ] [ event-dim ] bi gl-fill-rect ;

: event-text ( event -- string )
    [ event-beat ]
    [ event-dur ]
    [ event-midinote ] tri
    "beat %d dur %d midinote %d" sprintf ;

: top-pitch-value ( gadget -- pitch-value )
    screen-loc second pitch-height / -128 - ;

: mouse-pitch-value ( gadget -- pitch-value )
    top-pitch-value
    hand-loc get second pitch-height /
    - ;

: mouse-text ( gadget -- string )
    [ top-pitch-value ]
    [ drop hand-loc get first beat-width / ]
    [ mouse-pitch-value ] tri
    "top pitch %d beat %d midinote %d" sprintf ;

: mouse-text. ( gadget -- )
    ! screen-loc listener-.
    mouse-text listener-. ;

: draw-event-text ( event -- )
    event-text sans-serif-font swap draw-text ;

: draw-event ( event -- )
    dup event-pos [
        [ draw-event-rect ] [ draw-event-text ] bi
    ] with-translation ;

: draw-events ( gadget -- )
    model>> events>> [ draw-event ] each ;

: draw-test-text ( gadget -- )
    model>> events>> length "There are %d events." sprintf { 50 50 } [ sans-serif-font swap draw-text ] with-translation ;

: draw-test-box ( gadget -- )
    drop COLOR: hotpink gl-color
    { 50 150 } { 100 100 } gl-fill-rect ;

M: piano-roll-gadget draw-gadget*
    { [ draw-events ]
      ! [ draw-test-text ]
      ! [ draw-test-box ]
    } cleave ;

: events-total-dur ( events -- dur )
    [ [ event-beat ] [ event-dur ] bi + ] map 0 [ max ] reduce ;

: piano-roll-total-width ( gadget -- width )
    model>> events>> events-total-dur 1 + beat-width * ;

: piano-roll-total-height ( gadget -- height )
    event-height>> 128 * ;

M: piano-roll-gadget pref-dim*
    [ piano-roll-total-width ]
    [ piano-roll-total-height ] bi 2array ;

: <piano-roll-gadget> ( -- gadget )
    piano-roll-gadget new
    COLOR: gray12 <solid> >>interior
    <piano-roll> >>model
    dup current-piano-roll-gadget set-global ;

: piano-roll-refresh ( gadget -- )
    "refresh!" listener-.
    relayout-1 ;

: dump-gadget ( gadget -- )
    listener-. ;

: inspect-gadget ( gadget -- )
    inspector ;

: dump-events ( gadget -- )
    model>> events>> listener-. ;

: (handle-mouse-motion) ( piano-roll-gadget mouse-motion -- )
    nip listener-. ;

: piano-roll-drag ( gadget -- )
    drop drag-loc listener-. ;

! M: piano-roll-gadget handle-gesture
!     over T{ button-down } = [ dup request-focus ] when
!     stream>> [ . ] with-output-stream*
!     t ;

piano-roll-gadget {
    { T{ key-down { sym "g" } } [ piano-roll-refresh ] }
    { T{ key-down { sym "d" } } [ dump-events ] }
    { T{ key-down { sym "D" } } [ dump-gadget ] }
    { T{ key-down { sym "I" } } [ inspect-gadget ] }
    { T{ key-down { sym "M" } } [ mouse-text. ] }
    ! { T{ key-down { sym "2" } } [ com-medium ] }
    ! { T{ key-down { sym "3" } } [ com-hard ] }
    ! { T{ button-up { # 1 } } [ on-click ] }
    ! { T{ button-up { # 3 } } [ on-mark ] }
    ! { T{ key-down { sym " " } } [ on-mark ] }
    { T{ drag { # 1 } } [ piano-roll-drag ] }
} set-gestures

: piano-roll-ui ( -- )
    <piano-roll-gadget> <scroller> "Piano Roll" open-window ;

: test-piano-roll ( -- )
    piano-roll-ui
    piano-roll-model get-global
    5 [
        [ 10 random "beat"  ,,
          128 random "midinote" ,,
          4 random "dur" ,,
        ] H{ } make
    ] replicate >>events drop ;