/program-gadgets/program-gadgets.factor
Unknown | 77 lines | 66 code | 11 blank | 0 comment | 0 complexity | 3421d2f3230b8b45581e035d00c142d3 MD5 | raw file
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 ;