! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors
io.streams.duplex sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines tuples models continuations ;
IN: ui.gadgets.panes

TUPLE: pane output current prototype scrolls?
selection-color caret mark selecting? ;

: clear-selection ( pane -- )
    f over set-pane-caret
    f swap set-pane-mark ;

: add-output 2dup set-pane-output add-gadget ;

: add-current 2dup set-pane-current add-gadget ;

: prepare-line ( pane -- )
    dup clear-selection
    dup pane-prototype clone swap add-current ;

: pane-caret&mark ( pane -- caret mark )
    dup pane-caret swap pane-mark ;

: selected-children ( pane -- seq )
    [ pane-caret&mark sort-pair ] keep gadget-subtree ;

M: pane gadget-selection? pane-caret&mark and ;

M: pane gadget-selection
    selected-children gadget-text ;

: pane-clear ( pane -- )
    dup clear-selection
    dup pane-output clear-incremental
    pane-current clear-gadget ;

: pane-theme ( editor -- )
    selection-color swap set-pane-selection-color ;

: <pane> ( -- pane )
    pane construct-empty
    <pile> over set-delegate
    <shelf> over set-pane-prototype
    <pile> <incremental> over add-output
    dup prepare-line
    dup pane-theme ;

GENERIC: draw-selection ( loc obj -- )

: if-fits ( rect quot -- )
    >r clip get over intersects? r> [ drop ] if ; inline

M: gadget draw-selection ( loc gadget -- )
    swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;

M: node draw-selection ( loc node -- )
    2dup node-value swap offset-rect [
        drop 2dup
        [ node-value rect-loc v+ ] keep
        node-children [ draw-selection ] with each
    ] if-fits 2drop ;

M: pane draw-gadget*
    dup gadget-selection? [
        dup pane-selection-color gl-color
        origin get over rect-loc v- swap selected-children
        [ draw-selection ] with each
    ] [
        drop
    ] if ;

: scroll-pane ( pane -- )
    dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;

TUPLE: pane-stream pane ;

C: <pane-stream> pane-stream

: smash-line ( current -- gadget )
    dup gadget-children {
        { [ dup empty? ] [ 2drop "" <label> ] }
        { [ dup length 1 = ] [ nip first ] }
        { [ t ] [ drop ] }
    } cond ;

: smash-pane ( pane -- gadget ) pane-output smash-line ;

: pane-nl ( pane -- )
    dup pane-current dup unparent smash-line
    over pane-output add-incremental
    prepare-line ;

: pane-write ( pane seq -- )
    [ dup pane-nl ]
    [ over pane-current stream-write ]
    interleave drop ;

: pane-format ( style pane seq -- )
    [ dup pane-nl ]
    [ 2over pane-current stream-format ]
    interleave 2drop ;

GENERIC: write-gadget ( gadget stream -- )

M: pane-stream write-gadget
    pane-stream-pane pane-current add-gadget ;

M: duplex-stream write-gadget
    duplex-stream-out write-gadget ;

: print-gadget ( gadget stream -- )
    tuck write-gadget stream-nl ;

: gadget. ( gadget -- )
    stdio get print-gadget ;

: ?nl ( stream -- )
    dup pane-stream-pane pane-current gadget-children empty?
    [ dup stream-nl ] unless drop ;

: with-pane ( pane quot -- )
    over scroll>top
    over pane-clear >r <pane-stream> r>
    over >r with-stream* r> ?nl ; inline

: make-pane ( quot -- gadget )
    <pane> [ swap with-pane ] keep smash-pane ; inline

: <scrolling-pane> ( -- pane )
    <pane> t over set-pane-scrolls? ;

TUPLE: pane-control quot ;

M: pane-control model-changed
    swap model-value swap dup pane-control-quot with-pane ;

: <pane-control> ( model quot -- pane )
    >r <pane> pane-control construct-control r>
    over set-pane-control-quot ;

: do-pane-stream ( pane-stream quot -- )
    >r pane-stream-pane r> keep scroll-pane ; inline

M: pane-stream stream-nl
    [ pane-nl ] do-pane-stream ;

M: pane-stream stream-write1
    [ pane-current stream-write1 ] do-pane-stream ;

M: pane-stream stream-write
    [ swap string-lines pane-write ] do-pane-stream ;

M: pane-stream stream-format
    [ rot string-lines pane-format ] do-pane-stream ;

M: pane-stream dispose drop ;

M: pane-stream stream-flush drop ;

M: pane-stream make-span-stream
    <style-stream> <ignore-close-stream> ;

! Character styles

: apply-style ( style gadget key quot -- style gadget )
    >r pick at r> when* ; inline

: apply-foreground-style ( style gadget -- style gadget )
    foreground [ over set-label-color ] apply-style ;

: apply-background-style ( style gadget -- style gadget )
    background [ dupd solid-interior ] apply-style ;

: specified-font ( style -- font )
    [ font swap at "monospace" or ] keep
    [ font-style swap at plain or ] keep
    font-size swap at 12 or 3array ;

: apply-font-style ( style gadget -- style gadget )
    over specified-font over set-label-font ;

: apply-presentation-style ( style gadget -- style gadget )
    presented [ <presentation> ] apply-style ;

: <styled-label> ( style text -- gadget )
    <label>
    apply-foreground-style
    apply-background-style
    apply-font-style
    apply-presentation-style
    nip ;

! Paragraph styles

: apply-wrap-style ( style pane -- style pane )
    wrap-margin [
        2dup <paragraph> swap set-pane-prototype
        <paragraph> over set-pane-current
    ] apply-style ;

: apply-border-color-style ( style gadget -- style gadget )
    border-color [ dupd solid-boundary ] apply-style ;

: apply-page-color-style ( style gadget -- style gadget )
    page-color [ dupd solid-interior ] apply-style ;

: apply-path-style ( style gadget -- style gadget )
    presented-path [ <editable-slot> ] apply-style ;

: apply-border-width-style ( style gadget -- style gadget )
    border-width [ <border> ] apply-style ;

: apply-printer-style ( style gadget -- style gadget )
    presented-printer [
        [ make-pane ] curry over set-editable-slot-printer
    ] apply-style ;

: style-pane ( style pane -- pane )
    apply-border-width-style
    apply-border-color-style
    apply-page-color-style
    apply-presentation-style
    apply-path-style
    apply-printer-style
    nip ;

TUPLE: nested-pane-stream style parent ;

: <nested-pane-stream> ( style parent -- stream )
    >r <pane> apply-wrap-style <pane-stream> r> {
        set-nested-pane-stream-style
        set-delegate
        set-nested-pane-stream-parent
    } nested-pane-stream construct ;

: unnest-pane-stream ( stream -- child parent )
    dup ?nl
    dup nested-pane-stream-style
    over pane-stream-pane smash-pane style-pane
    swap nested-pane-stream-parent ;

TUPLE: pane-block-stream ;

M: pane-block-stream dispose
    unnest-pane-stream write-gadget ;

M: pane-stream make-block-stream
    <nested-pane-stream> pane-block-stream construct-delegate ;

! Tables
: apply-table-gap-style ( style grid -- style grid )
    table-gap [ over set-grid-gap ] apply-style ;

: apply-table-border-style ( style grid -- style grid )
    table-border [ <grid-lines> over set-gadget-boundary ]
    apply-style ;

: styled-grid ( style grid -- grid )
    <grid>
    f over set-grid-fill?
    apply-table-gap-style
    apply-table-border-style
    nip ;

TUPLE: pane-cell-stream ;

M: pane-cell-stream dispose ?nl ;

M: pane-stream make-cell-stream
    <nested-pane-stream> pane-cell-stream construct-delegate ;

M: pane-stream stream-write-table
    >r
    swap [ [ pane-stream-pane smash-pane ] map ] map
    styled-grid
    r> print-gadget ;

! Stream utilities
M: pack dispose drop ;

M: paragraph dispose drop ;

: gadget-write ( string gadget -- )
    over empty? [
        2drop
    ] [
        >r <label> dup text-theme r> add-gadget
    ] if ;

M: pack stream-write gadget-write ;

: gadget-bl ( style stream -- )
    >r " " <styled-label> <word-break-gadget> r> add-gadget ;

M: paragraph stream-write
    swap " " split
    [ H{ } over gadget-bl ] [ over gadget-write ] interleave
    drop ;

: gadget-write1 ( char gadget -- )
    >r 1string r> stream-write ;

M: pack stream-write1 gadget-write1 ;

M: paragraph stream-write1
    over CHAR: \s =
    [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;

: gadget-format ( string style stream -- )
    pick empty?
    [ 3drop ] [ >r swap <styled-label> r> add-gadget ] if ;

M: pack stream-format
    gadget-format ;

M: paragraph stream-format
    presented pick at [
        gadget-format
    ] [
        rot " " split
        [ 2dup gadget-bl ]
        [ 2over gadget-format ] interleave
        2drop
    ] if ;

: caret>mark ( pane -- )
    dup pane-caret over set-pane-mark relayout-1 ;

GENERIC: sloppy-pick-up* ( loc gadget -- n )

M: pack sloppy-pick-up*
    dup gadget-orientation
    swap gadget-children
    (fast-children-on) ;

M: gadget sloppy-pick-up*
    gadget-children [ inside? ] with find-last drop ;

M: f sloppy-pick-up*
    2drop f ;

: wet-and-sloppy ( loc gadget n -- newloc newgadget )
    swap nth-gadget [ rect-loc v- ] keep ;

: sloppy-pick-up ( loc gadget -- path )
    2dup sloppy-pick-up* dup
    [ [ wet-and-sloppy sloppy-pick-up ] keep add* ]
    [ 3drop { } ]
    if ;

: move-caret ( pane -- )
    dup hand-rel
    over sloppy-pick-up
    over set-pane-caret
    relayout-1 ;

: begin-selection ( pane -- )
    dup move-caret f swap set-pane-mark ;

: extend-selection ( pane -- )
    hand-moved? [
        dup pane-selecting? [
            dup move-caret
        ] [
            dup hand-clicked get child? [
                t over set-pane-selecting?
                dup hand-clicked set-global
                dup move-caret
                dup caret>mark
            ] when
        ] if
        dup dup pane-caret gadget-at-path scroll>gadget
    ] when drop ;

: end-selection ( pane -- )
    f over set-pane-selecting?
    hand-moved? [
        dup com-copy-selection
        request-focus
    ] [
        relayout-1
    ] if ;

: select-to-caret ( pane -- )
    dup pane-mark [ dup caret>mark ] unless
    dup move-caret
    dup request-focus
    com-copy-selection ;

pane H{
    { T{ button-down } [ begin-selection ] }
    { T{ button-down f { S+ } 1 } [ select-to-caret ] }
    { T{ button-up f { S+ } 1 } [ drop ] }
    { T{ button-up } [ end-selection ] }
    { T{ drag } [ extend-selection ] }
    { T{ copy-action } [ com-copy ] }
} set-gestures