rgchris/presentation.r

## presentation.r
Rebol [
    Title: "Presentation Style"
    Author: "Christopher Ross-Gill"
    Date: 20-Sep-2004
    History: {
        Based on "Presentation Dialect" by Jeff Kreis
        15-Jan-2001
        https://www.cs.unm.edu/~whip/make-presentation.r
        https://www.cs.unm.edu/~whip/test-prez.r

        Converts it to a slide-based style.
        Has bugs.
    }
]

random/seed now/time

vids: copy []

foreach [w f] system/view/vid/vid-styles [
    append vids w
]

vids: make hash! vids

count-faces: func [code count] [
    foreach w code [
        if find vids w [
            count: count + 1
        ]
    ]
    count
]

; --- Presentation Dialect ---
parse-prez: func [
    prez "Presentation Dialect"
    /local
    out this-scene this-layout effect-time appear-time prez-act m1 m count
][
    if not parse prez [
        (
            this-scene: copy []
            this-layout: copy []
            count: 0
        )

        some [
            copy prez-part to time! (
                effect-chunk: copy []
            )

            set appear-time time!

            into [  ; -- Effect level
                m1: any [
                    set effect-time time!
                    (prez-info: copy [])

                    m: set prez-act ['fade | 'grow | 'move | 'go] :m
                    [
                        'fade
                        set tup opt [tuple! | word!]
                        set num integer!
                        set fac opt word!
                        (
                            if word? tup [
                                if not tuple? tup: get tup [
                                    tup: none
                                ]
                            ]

                            repend prez-info [tup num fac]
                        )
                        |
                        ['grow | 'move | 'go]
                        set pair pair!
                        set num integer!
                        (repend prez-info [pair num])
                    ]

                    (repend effect-chunk [prez-act prez-info effect-time])
                ]
            ]
            (
                ; -- add effects for an element
                count: count-faces prez-part count
                append this-layout prez-part
                repend this-scene [count effect-chunk appear-time]
            )
        ]
    ][
        print ["Failed to parse near:" mold m1]
        return none
    ]

    reduce [
        'layout this-layout
        'scene this-scene
    ]
]

; --- Effects Execution ---
do-effects: func [
    face [object!]
    effects [block!]
    t1 [time!]
    /local i
][
    i: 1
    foreach [effect data time] copy effects [
        if time <= t1 [
            if 'init <> last data [
                ; print ["initializing" effect face/style face/text]
                do bind reduce [to-word join 'init- effect face data] 'self
                append data 'init
            ]
            if not do bind reduce [effect face data] 'self [
                ; print ["Completed" effect face/style face/text]
                remove/part at effects i 3
                i: i - 3
            ]
        ]
        i: i + 3
    ]
]

dist: func [a b c] [
    to-integer ((a - b) / c)
]

; --- Move Effect ---
move: func [
    face [object!]
    data [block!]
][
    do-space face data 'offset
]

init-move: func [
    face [object!]
    data [block!]
    /local pair ticks
][
    set [pair ticks] data

    if any [not pair? pair not integer? ticks] [
        make error! reform [
            "Bad data to init-move" mold data
        ]
    ]

    change data reduce [ticks pair]
]

; --- Go Effect ---
go: func [
    face
    data [block!]
    /local offset ticks
][
    do-space face data 'offset
]

init-go: func [
    face [object!]
    data [block!]
][
    init-space face data 'offset
]

; --- Space Subeffect ---
do-space: func [
    face [object!] data [block!] facet [word!]
    /local which
][
    which: get in face facet
    set in face facet which + data/2
    show face
    change data data/1 - 1
    data/1 >= 0
]

init-space: func [
    face [object!]
    data [block!]
    facet [word!]
    /local pair ticks which delta
][
    which: get in face facet

    set [pair ticks] data

    if any [not pair? pair not integer? ticks] [
        make error! reform ["Bad data to init-space:" mold data]
    ]

    ticks: abs ticks

    delta: to-pair reduce [
        dist pair/x which/x ticks
        dist pair/y which/y ticks
    ]

    change data reduce [ticks delta pair]
]

; --- Grow Effect ---
grow: func [
    face [object!]
    data [block!]
    /local size
][
    do-space face data 'size
]

init-grow: func [
    face [object!]
    data [block!]
    /local size
][
    init-space face data 'size

    either block? face/effect [
        append face/effect 'fit
    ][
        face/effect: [fit]
    ]
]

; --- Fade Effect ---
delt-tuple: func [a b /local result] [
    result: copy []
    repeat i length? a [
        append result max 0 min 255 (pick a i) + pick b i
    ]
    to-tuple result
]

fade: func [
    face [object!] data [block!]
    /local ticks afc aft afe fade-img fade-img-spot c facet
][

    ; print ["fade" data]

    set [ticks afc aft afe fade-img fade-img-spot facet] data

    if fade-img [
        change fade-img-spot fade-img-spot/1 + fade-img
    ]
    either facet [
        switch/default facet [
            text [
                all [
                    face/font
                    face/font/color: delt-tuple aft face/font/color
                ]
            ]

            edge [
                all [
                    face/edge
                    face/edge/color: delt-tuple afe face/edge/color
                ]
            ]

            full [
                all [
                    face/edge
                    face/edge/color: delt-tuple afe face/edge/color
                ]

                all [
                    face/font
                    face/font/color: delt-tuple aft face/font/color
                ]

                all [
                    face/color
                    face/color: delt-tuple afc face/color
                    block? face/colors 2 <= length? face/colors
                    change face/colors face/color
                ]
            ]
            ; body [default]
        ][
            all [
                face/color
                face/color: delt-tuple afc face/color
                block? face/colors 2 <= length? face/colors
                change face/colors face/color
            ]
        ]
    ][
        ; -- otherwise, decide based on what's there
        if c: face/color [
            face/color: delt-tuple afc c
        ]

        if c: face/font/color [
            face/font/color: delt-tuple aft c
        ]
    ]

    show face

    ; -- amount of ticks of this
    change data ticks - 1

    data/1 >= 0
]

init-fade: func [
    face [object!]
    data [block!]
    /local eff t1 t2 afc aft afe fade-img fade-img-spot ticks facet
][
    set [t1 ticks facet] data

    if not t1 [
        t1: 0.0.0
    ]

    if not ticks [
        ticks: 10
    ]

    set [fade-img fade-img-spot] none

    if face/image [
        eff: reduce [
            'brighten
            pick [0 -255] negative? ticks
        ]

        either not block? face/effect [
            face/effect: eff
        ][
            append face/effect eff
        ]

        fade-img: to-integer (255 / ticks)
        fade-img-spot: back tail face/effect
    ]

    ticks: abs ticks

    if afc: face/color [
        afc: reduce [
            dist t1/1 afc/1 ticks
            dist t1/2 afc/2 ticks
            dist t1/3 afc/3 ticks
        ]
    ]

    if all [aft: face/font aft: aft/color] [
        aft: reduce [
            dist t1/1 aft/1 ticks
            dist t1/2 aft/2 ticks
            dist t1/3 aft/3 ticks
        ]
    ]

    if all [afe: face/edge afe: afe/color] [
        afe: reduce [
            dist t1/1 afe/1 ticks
            dist t1/2 afe/2 ticks
            dist t1/3 afe/3 ticks
        ]
    ]

    change data reduce [
        ticks
        afc
        aft
        afe
        fade-img
        fade-img-spot
        facet
    ]
]

; --- Style Code ---

prez-feel: make svvf/sensor [
    engage: func [face action event] [
        if action = 'time [
            face/update
        ]
    ]
]

stylize/master [
    PRESENTATION: IMAGE with [
        feel: prez-feel
        restore-rate: rate: 24

        layout-card: func [card [block!]] [
            get in layout/origin/offset/size card 20x10 0x0 size 'pane
        ]

        active: cards: copy []
        pane: copy []
        scene: current: store: none

        ; --- Controls ---
        goto: func [card-id [issue!]] [
            rate: restore-rate
            active: any [
                find cards card-id
                active
            ]
            set-scene
            show self
        ]

        next-scene: does [
            rate: restore-rate
            either any [tail? active tail? active: skip active 3] [
                either confirm "End of Presentation. Quit?" [
                    quit
                ][
                    rate: none
                ]
            ][
                set-scene
                show self
            ]
        ]

        back-scene: does [
            rate: restore-rate
            if not head? active [active: skip active -3]
            set-scene
            show self
        ]

        ; --- Action Trigger ---
        update: has [t1 i] [
            t1: now/time
            i: 0
            if empty? scene [next-scene]

            foreach [subface effects appear-time] copy scene [
                if appear-time <= t1 [
                    either subface/user-data [
                        either not empty? effects [
                            do-effects subface effects t1
                        ][
                            remove/part at scene i 3
                            i: i - 3
                        ]
                    ][
                        subface/user-data: on
                        if find [backdrop backtile] subface/style [
                            subface/size: size
                        ]
                        append pane subface
                        do-effects subface effects t1
                        show self
                    ]
                ]
                i: i + 3
            ]
        ]

        ; --- Initialise Scene ---
        set-scene: has [
            begin count i eff act info t1 t2 bg
        ][
            set [current scene store] copy/deep/part active 3

            scene: copy scene store: layout-card store

            clear pane recycle

            begin: now/time
            count: 0

            scene: head forskip scene 3 [
                set [i eff t1] scene
                append pane copy/part skip store count at store i
                count: i
                change scene pick store i
                change at scene 3 begin + t1
                forskip eff 3 [
                    set [act info t2] eff
                    change at eff 3 begin + t1 + t2
                ]
                scene
            ]

            if not empty? store [
                if find [backdrop backtile] store/1/style [
                    store/1/size: size
                ]
            ]
        ]

        ; --- Startup ---
        append init [
            foreach [id card] second :action [
                either block? card [
                    card: parse-prez card
                    insert tail cards reduce [
                        id card/scene card/layout
                    ]
                ][
                    alert join "Error: No Card To Format -- " mold id
                ]
            ]

            restore-rate: rate
            active: cards
            set-scene
        ]
    ]
]

## test-prez.r
Rebol [
    Title: "Prez Test"
    Date: 2-Feb-2021
    Author: "Christopher Ross-Gill"
]

ctx-prez: make object! load %presentation.r

view center-face layout [
    origin 0
    presentation 500x300 [
        #card-1 [
            at 10x-200
            backdrop white
            h1 "Card 1" 480 :0:1 [
                :0:0 move 0x6 100
                :0:1 fade red 50
            ]
        ]

        #card-2 [
            at 10x500
            h1 "Card 2" 480 :0:1 [
                :0:0 move 0x-6 100
                :0:1 fade green 50
            ]
        ]
    ]
]
	Rebol [
	Title: "Presentation Style"
	Author: "Christopher Ross-Gill"
	Date: 20-Sep-2004
	History: {
	Based on "Presentation Dialect" by Jeff Kreis
	15-Jan-2001
	https://www.cs.unm.edu/~whip/make-presentation.r
	https://www.cs.unm.edu/~whip/test-prez.r

	Converts it to a slide-based style.
	Has bugs.
	}
	]

	random/seed now/time

	vids: copy []

	foreach [w f] system/view/vid/vid-styles [
	append vids w
	]

	vids: make hash! vids

	count-faces: func [code count] [
	foreach w code [
	if find vids w [
	count: count + 1
	]
	]
	count
	]

	; --- Presentation Dialect ---
	parse-prez: func [
	prez "Presentation Dialect"
	/local
	out this-scene this-layout effect-time appear-time prez-act m1 m count
	][
	if not parse prez [
	(
	this-scene: copy []
	this-layout: copy []
	count: 0
	)

	some [
	copy prez-part to time! (
	effect-chunk: copy []
	)

	set appear-time time!

	into [ ; -- Effect level
	m1: any [
	set effect-time time!
	(prez-info: copy [])

	m: set prez-act ['fade \| 'grow \| 'move \| 'go] :m
	[
	'fade
	set tup opt [tuple! \| word!]
	set num integer!
	set fac opt word!
	(
	if word? tup [
	if not tuple? tup: get tup [
	tup: none
	]
	]

	repend prez-info [tup num fac]
	)
	\|
	['grow \| 'move \| 'go]
	set pair pair!
	set num integer!
	(repend prez-info [pair num])
	]

	(repend effect-chunk [prez-act prez-info effect-time])
	]
	]
	(
	; -- add effects for an element
	count: count-faces prez-part count
	append this-layout prez-part
	repend this-scene [count effect-chunk appear-time]
	)
	]
	][
	print ["Failed to parse near:" mold m1]
	return none
	]

	reduce [
	'layout this-layout
	'scene this-scene
	]
	]

	; --- Effects Execution ---
	do-effects: func [
	face [object!]
	effects [block!]
	t1 [time!]
	/local i
	][
	i: 1
	foreach [effect data time] copy effects [
	if time <= t1 [
	if 'init <> last data [
	; print ["initializing" effect face/style face/text]
	do bind reduce [to-word join 'init- effect face data] 'self
	append data 'init
	]
	if not do bind reduce [effect face data] 'self [
	; print ["Completed" effect face/style face/text]
	remove/part at effects i 3
	i: i - 3
	]
	]
	i: i + 3
	]
	]

	dist: func [a b c] [
	to-integer ((a - b) / c)
	]

	; --- Move Effect ---
	move: func [
	face [object!]
	data [block!]
	][
	do-space face data 'offset
	]

	init-move: func [
	face [object!]
	data [block!]
	/local pair ticks
	][
	set [pair ticks] data

	if any [not pair? pair not integer? ticks] [
	make error! reform [
	"Bad data to init-move" mold data
	]
	]

	change data reduce [ticks pair]
	]

	; --- Go Effect ---
	go: func [
	face
	data [block!]
	/local offset ticks
	][
	do-space face data 'offset
	]

	init-go: func [
	face [object!]
	data [block!]
	][
	init-space face data 'offset
	]

	; --- Space Subeffect ---
	do-space: func [
	face [object!] data [block!] facet [word!]
	/local which
	][
	which: get in face facet
	set in face facet which + data/2
	show face
	change data data/1 - 1
	data/1 >= 0
	]

	init-space: func [
	face [object!]
	data [block!]
	facet [word!]
	/local pair ticks which delta
	][
	which: get in face facet

	set [pair ticks] data

	if any [not pair? pair not integer? ticks] [
	make error! reform ["Bad data to init-space:" mold data]
	]

	ticks: abs ticks

	delta: to-pair reduce [
	dist pair/x which/x ticks
	dist pair/y which/y ticks
	]

	change data reduce [ticks delta pair]
	]

	; --- Grow Effect ---
	grow: func [
	face [object!]
	data [block!]
	/local size
	][
	do-space face data 'size
	]

	init-grow: func [
	face [object!]
	data [block!]
	/local size
	][
	init-space face data 'size

	either block? face/effect [
	append face/effect 'fit
	][
	face/effect: [fit]
	]
	]

	; --- Fade Effect ---
	delt-tuple: func [a b /local result] [
	result: copy []
	repeat i length? a [
	append result max 0 min 255 (pick a i) + pick b i
	]
	to-tuple result
	]

	fade: func [
	face [object!] data [block!]
	/local ticks afc aft afe fade-img fade-img-spot c facet
	][

	; print ["fade" data]

	set [ticks afc aft afe fade-img fade-img-spot facet] data

	if fade-img [
	change fade-img-spot fade-img-spot/1 + fade-img
	]
	either facet [
	switch/default facet [
	text [
	all [
	face/font
	face/font/color: delt-tuple aft face/font/color
	]
	]

	edge [
	all [
	face/edge
	face/edge/color: delt-tuple afe face/edge/color
	]
	]

	full [
	all [
	face/edge
	face/edge/color: delt-tuple afe face/edge/color
	]

	all [
	face/font
	face/font/color: delt-tuple aft face/font/color
	]

	all [
	face/color
	face/color: delt-tuple afc face/color
	block? face/colors 2 <= length? face/colors
	change face/colors face/color
	]
	]
	; body [default]
	][
	all [
	face/color
	face/color: delt-tuple afc face/color
	block? face/colors 2 <= length? face/colors
	change face/colors face/color
	]
	]
	][
	; -- otherwise, decide based on what's there
	if c: face/color [
	face/color: delt-tuple afc c
	]

	if c: face/font/color [
	face/font/color: delt-tuple aft c
	]
	]

	show face

	; -- amount of ticks of this
	change data ticks - 1

	data/1 >= 0
	]

	init-fade: func [
	face [object!]
	data [block!]
	/local eff t1 t2 afc aft afe fade-img fade-img-spot ticks facet
	][
	set [t1 ticks facet] data

	if not t1 [
	t1: 0.0.0
	]

	if not ticks [
	ticks: 10
	]

	set [fade-img fade-img-spot] none

	if face/image [
	eff: reduce [
	'brighten
	pick [0 -255] negative? ticks
	]

	either not block? face/effect [
	face/effect: eff
	][
	append face/effect eff
	]

	fade-img: to-integer (255 / ticks)
	fade-img-spot: back tail face/effect
	]

	ticks: abs ticks

	if afc: face/color [
	afc: reduce [
	dist t1/1 afc/1 ticks
	dist t1/2 afc/2 ticks
	dist t1/3 afc/3 ticks
	]
	]

	if all [aft: face/font aft: aft/color] [
	aft: reduce [
	dist t1/1 aft/1 ticks
	dist t1/2 aft/2 ticks
	dist t1/3 aft/3 ticks
	]
	]

	if all [afe: face/edge afe: afe/color] [
	afe: reduce [
	dist t1/1 afe/1 ticks
	dist t1/2 afe/2 ticks
	dist t1/3 afe/3 ticks
	]
	]

	change data reduce [
	ticks
	afc
	aft
	afe
	fade-img
	fade-img-spot
	facet
	]
	]

	; --- Style Code ---

	prez-feel: make svvf/sensor [
	engage: func [face action event] [
	if action = 'time [
	face/update
	]
	]
	]

	stylize/master [
	PRESENTATION: IMAGE with [
	feel: prez-feel
	restore-rate: rate: 24

	layout-card: func [card [block!]] [
	get in layout/origin/offset/size card 20x10 0x0 size 'pane
	]

	active: cards: copy []
	pane: copy []
	scene: current: store: none

	; --- Controls ---
	goto: func [card-id [issue!]] [
	rate: restore-rate
	active: any [
	find cards card-id
	active
	]
	set-scene
	show self
	]

	next-scene: does [
	rate: restore-rate
	either any [tail? active tail? active: skip active 3] [
	either confirm "End of Presentation. Quit?" [
	quit
	][
	rate: none
	]
	][
	set-scene
	show self
	]
	]

	back-scene: does [
	rate: restore-rate
	if not head? active [active: skip active -3]
	set-scene
	show self
	]

	; --- Action Trigger ---
	update: has [t1 i] [
	t1: now/time
	i: 0
	if empty? scene [next-scene]

	foreach [subface effects appear-time] copy scene [
	if appear-time <= t1 [
	either subface/user-data [
	either not empty? effects [
	do-effects subface effects t1
	][
	remove/part at scene i 3
	i: i - 3
	]
	][
	subface/user-data: on
	if find [backdrop backtile] subface/style [
	subface/size: size
	]
	append pane subface
	do-effects subface effects t1
	show self
	]
	]
	i: i + 3
	]
	]

	; --- Initialise Scene ---
	set-scene: has [
	begin count i eff act info t1 t2 bg
	][
	set [current scene store] copy/deep/part active 3

	scene: copy scene store: layout-card store

	clear pane recycle

	begin: now/time
	count: 0

	scene: head forskip scene 3 [
	set [i eff t1] scene
	append pane copy/part skip store count at store i
	count: i
	change scene pick store i
	change at scene 3 begin + t1
	forskip eff 3 [
	set [act info t2] eff
	change at eff 3 begin + t1 + t2
	]
	scene
	]

	if not empty? store [
	if find [backdrop backtile] store/1/style [
	store/1/size: size
	]
	]
	]

	; --- Startup ---
	append init [
	foreach [id card] second :action [
	either block? card [
	card: parse-prez card
	insert tail cards reduce [
	id card/scene card/layout
	]
	][
	alert join "Error: No Card To Format -- " mold id
	]
	]

	restore-rate: rate
	active: cards
	set-scene
	]
	]
	]
	Rebol [
	Title: "Prez Test"
	Date: 2-Feb-2021
	Author: "Christopher Ross-Gill"
	]

	ctx-prez: make object! load %presentation.r

	view center-face layout [
	origin 0
	presentation 500x300 [
	#card-1 [
	at 10x-200
	backdrop white
	h1 "Card 1" 480 :0:1 [
	:0:0 move 0x6 100
	:0:1 fade red 50
	]
	]

	#card-2 [
	at 10x500
	h1 "Card 2" 480 :0:1 [
	:0:0 move 0x-6 100
	:0:1 fade green 50
	]
	]
	]
	]