/program-gadgets/program-gadgets.factor

 1USING: kernel accessors sequences arrays math math.bitwise
 2       giplayer.listings math.parser math.order
 3       models ui ui.gadgets ui.gadgets.packs ui.gadgets.labels
 4       ui.gadgets.panes ui.gadgets.borders ui.gadgets.scrollers
 5       ui.tools.common ui.pens.solid
 6       io.styles io locals colors fonts calendar.format ;
 7
 8IN: giplayer.program-gadgets
 9
10TUPLE: programme-list < pack ;
11
12: <noprogrammes-gadget> ( -- gadget )
13    "No programmes found" <label> ;
14
15: <programme-list> ( listing-model -- gadget )
16    programme-list new
17        swap >>model
18        1 >>fill
19        { 0 10 } >>gap
20    <noprogrammes-gadget> add-gadget
21    <scroller> ;
22
23: kth-page ( pagelen k seq -- subseq )
24    3dup [ * ] [ length ] bi* <
25    [
26        [ [ * ] [ 1 + * ] 2bi ] dip [ length ] keep
27        [ min ] dip subseq
28    ] [ 3drop { } clone ] if ;
29
30! Hash the station name to a 32 bit integer, then take 21 bits to get
31! 3 numbers 0-128. Now add 128 to each (and divide to put into [0,1]).
32: programme-colour ( l -- colour )
33    channel>> reverse hashcode
34    { HEX: 7f HEX: 3fff HEX: 1fffff } [ mask ] with map
35    { 0 -7 -14 } [ shift 128 + 256 /f ] 2map
36    first3 1 <rgba> ;
37
38: output-categories ( l -- )
39    { { wrap-margin 500 } { inset { 10 0 } } } swap
40    categories>> [    
41        [
42            "\n" append { { font-size 12 } } format
43        ] each
44    ] curry with-nesting ;
45
46:: output-programme ( l -- )
47    { { wrap-margin 500 } { inset { 5 0 } } }
48    [
49        l name>> { { font-size 17 } } format
50        l channel>> " (from " ")" surround
51        { { font-size 15 } } format
52    ] with-nesting
53    nl
54    { { wrap-margin 500 } { inset { 10 0 } } }
55    [
56        l episode>> { { font-size 15 } } format
57        nl
58        "Added: " l timeadded>> file-time-string append
59        { { font-size 15 } } format
60    ] with-nesting
61    nl
62    { { wrap-margin 500 } { inset { 20 6 } } }
63    [ l description>> { { font-size 14 } } format ] with-nesting
64    nl
65    l output-categories ;
66
67: <program-gadget> ( listing -- gadget )
68    dup [ output-programme ] make-pane
69        swap programme-colour <solid> >>interior ;
70
71: pl-child-gadgets ( model -- gadgets )
72    value>> dup empty?
73    [ drop <noprogrammes-gadget> 1array ]
74    [ [ 10 0 ] dip kth-page [ <program-gadget> ] map ] if ;
75
76M: programme-list model-changed
77    [ clear-gadget ] keep swap pl-child-gadgets add-gadgets drop ;