<commit_before>! Copyright (C) 2005, 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.tuple colors
colors.constants combinators combinators.short-circuit
combinators.smart fry kernel locals math math.rectangles
math.vectors models namespaces opengl opengl.gl quotations
sequences strings ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.packs ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.worlds ui.gestures ui.pens
ui.pens.image ui.pens.solid ui.pens.tile ;
FROM: models => change-model ;
IN: ui.gadgets.buttons

TUPLE: button < border pressed? selected? quot tooltip ;

<PRIVATE

: find-button ( gadget -- button )
    [ button? ] find-parent ;

: buttons-down? ( -- ? )
    hand-buttons get-global empty? not ;

: button-rollover? ( button -- ? )
    hand-gadget get-global child? ;

: mouse-clicked? ( gadget -- ? )
    hand-clicked get-global child? ;

PRIVATE>

: button-update ( button -- )
    dup
    { [ mouse-clicked? ] [ button-rollover? ] } 1&&
    buttons-down? and
    >>pressed?
    relayout-1 ;

: button-enter ( button -- )
    dup dup tooltip>> [ swap show-status ] [ drop ] if* button-update ;

: button-leave ( button -- )
    dup "" swap show-status button-update ;

: button-clicked ( button -- )
    [ ]
    [ button-update ]
    [ button-rollover? ] tri
    [ dup quot>> call( button -- ) ] [ drop ] if ;

button H{
    { T{ button-up } [ button-clicked ] }
    { T{ button-down } [ button-update ] }
    { mouse-leave [ button-leave ] }
    { mouse-enter [ button-enter ] }
} set-gestures

: new-button ( label quot class -- button )
    [ swap >label ] dip new-border swap >>quot ; inline

: <button> ( label quot -- button )
    button new-button ;

TUPLE: button-pen
plain rollover
pressed selected pressed-selected ;

C: <button-pen> button-pen

: button-pen ( button pen -- button pen )
    over find-button {
        { [ dup { [ pressed?>> ] [ selected?>> ] } 1&& ] [
            drop pressed-selected>>
        ] }
        { [ dup pressed?>> ] [ drop pressed>> ] }
        { [ dup selected?>> ] [ drop selected>> ] }
        { [ dup button-rollover? ] [ drop rollover>> ] }
        [ drop plain>> ]
    } cond ;

M: button-pen draw-interior
    button-pen dup [ draw-interior ] [ 2drop ] if ;

M: button-pen draw-boundary
    button-pen dup [ draw-boundary ] [ 2drop ] if ;

M: button-pen pen-pref-dim
    [
        {
            [ plain>> pen-pref-dim ]
            [ rollover>> pen-pref-dim ]
            [ pressed>> pen-pref-dim ]
            [ selected>> pen-pref-dim ]
        } 2cleave
    ] [ vmax ] reduce-outputs ;

M: button-pen pen-background
    button-pen pen-background ;

M: button-pen pen-foreground
    button-pen pen-foreground ;

<PRIVATE

: align-left ( button -- button )
    { 0 1/2 } >>align ; inline

: roll-button-theme ( button -- button )
    f COLOR: black <solid> dup f f <button-pen> >>boundary
    f f COLOR: dark-gray <solid> f f <button-pen> >>interior
    align-left ; inline

PRIVATE>

: <roll-button> ( label quot -- button )
    <button> roll-button-theme ;

<PRIVATE

: <border-button-state-pen> ( prefix background foreground -- pen )
    [
        "-left" "-middle" "-right"
        [ append theme-image ] tri-curry@ tri
    ] 2dip <tile-pen> ;<commit_msg>issue #358: Rename button-pen -> lookup-button-pen.<commit_after>! Copyright (C) 2005, 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.tuple colors
colors.constants combinators combinators.short-circuit
combinators.smart fry kernel locals math math.rectangles
math.vectors models namespaces opengl opengl.gl quotations
sequences strings ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.packs ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.worlds ui.gestures ui.pens
ui.pens.image ui.pens.solid ui.pens.tile ;
FROM: models => change-model ;
IN: ui.gadgets.buttons

TUPLE: button < border pressed? selected? quot tooltip ;

<PRIVATE

: find-button ( gadget -- button )
    [ button? ] find-parent ;

: buttons-down? ( -- ? )
    hand-buttons get-global empty? not ;

: button-rollover? ( button -- ? )
    hand-gadget get-global child? ;

: mouse-clicked? ( gadget -- ? )
    hand-clicked get-global child? ;

PRIVATE>

: button-update ( button -- )
    dup
    { [ mouse-clicked? ] [ button-rollover? ] } 1&&
    buttons-down? and
    >>pressed?
    relayout-1 ;

: button-enter ( button -- )
    dup dup tooltip>> [ swap show-status ] [ drop ] if* button-update ;

: button-leave ( button -- )
    dup "" swap show-status button-update ;

: button-clicked ( button -- )
    [ ]
    [ button-update ]
    [ button-rollover? ] tri
    [ dup quot>> call( button -- ) ] [ drop ] if ;

button H{
    { T{ button-up } [ button-clicked ] }
    { T{ button-down } [ button-update ] }
    { mouse-leave [ button-leave ] }
    { mouse-enter [ button-enter ] }
} set-gestures

: new-button ( label quot class -- button )
    [ swap >label ] dip new-border swap >>quot ; inline

: <button> ( label quot -- button )
    button new-button ;

TUPLE: button-pen
plain rollover
pressed selected pressed-selected ;

C: <button-pen> button-pen

: lookup-button-pen ( button pen -- button pen )
    over find-button {
        { [ dup { [ pressed?>> ] [ selected?>> ] } 1&& ] [
            drop pressed-selected>>
        ] }
        { [ dup pressed?>> ] [ drop pressed>> ] }
        { [ dup selected?>> ] [ drop selected>> ] }
        { [ dup button-rollover? ] [ drop rollover>> ] }
        [ drop plain>> ]
    } cond ;

M: button-pen draw-interior
    lookup-button-pen dup [ draw-interior ] [ 2drop ] if ;

M: button-pen draw-boundary
    lookup-button-pen dup [ draw-boundary ] [ 2drop ] if ;

M: button-pen pen-pref-dim
    [
        {
            [ plain>> pen-pref-dim ]
            [ rollover>> pen-pref-dim ]
            [ pressed>> pen-pref-dim ]
            [ selected>> pen-pref-dim ]
        } 2cleave
    ] [ vmax ] reduce-outputs ;

M: button-pen pen-background
    lookup-button-pen pen-background ;

M: button-pen pen-foreground
    lookup-button-pen pen-foreground ;

<PRIVATE

: align-left ( button -- button )
    { 0 1/2 } >>align ; inline

: roll-button-theme ( button -- button )
    f COLOR: black <solid> dup f f <button-pen> >>boundary
    f f COLOR: dark-gray <solid> f f <button-pen> >>interior
    align-left ; inline

PRIVATE>

: <roll-button> ( label quot -- button )
    <button> roll-button-theme ;

<PRIVATE

: <border-button-state-pen> ( prefix background foreground -- pen )
    [
        "-left" "-middle" "-right"
        [ append theme-image ] tri-curry@ tri
    ] 2dip <tile-pen> ;
{'fraction_non_alphanumeric': 0.14289971688272984, 'fraction_numerical': 0.00581135449262405, 'mean_word_length': 2.4813278008298756, 'pattern_counts': {'":': 0, '<': 33, '<?xml version=': 0, '>': 114, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6068977', 'n_tokens_mistral': 2273, 'n_tokens_neox': 2216, 'n_words': 566}