/program-gadgets/program-gadgets.factor

http://github.com/rswarbrick/giplayer · Factor · 77 lines · 64 code · 11 blank · 2 comment · 2 complexity · 3421d2f3230b8b45581e035d00c142d3 MD5 · raw file 

    

  1. USING: kernel accessors sequences arrays math math.bitwise
    2. 

  2.        giplayer.listings math.parser math.order
    3. 

  3.        models ui ui.gadgets ui.gadgets.packs ui.gadgets.labels
    4. 

  4.        ui.gadgets.panes ui.gadgets.borders ui.gadgets.scrollers
    5. 

  5.        ui.tools.common ui.pens.solid
    6. 

  6.        io.styles io locals colors fonts calendar.format ;
    7. 

  7. 

  8. IN: giplayer.program-gadgets
    9. 

  9. 

  10. TUPLE: programme-list < pack ;
    11. 

  11. 

  12. : <noprogrammes-gadget> ( -- gadget )
    13. 

  13.     "No programmes found" <label> ;
    14. 

  14. 

  15. : <programme-list> ( listing-model -- gadget )
    16. 

  16.     programme-list new
    17. 

  17.         swap >>model
    18. 

  18.         1 >>fill
    19. 

  19.         { 0 10 } >>gap
    20. 

  20.     <noprogrammes-gadget> add-gadget
    21. 

  21.     <scroller> ;
    22. 

  22. 

  23. : kth-page ( pagelen k seq -- subseq )
    24. 

  24.     3dup [ * ] [ length ] bi* <
    25. 

  25.     [
    26. 

  26.         [ [ * ] [ 1 + * ] 2bi ] dip [ length ] keep
    27. 

  27.         [ min ] dip subseq
    28. 

  28.     ] [ 3drop { } clone ] if ;
    29. 

  29. 

  30. ! Hash the station name to a 32 bit integer, then take 21 bits to get
    31. 

  31. ! 3 numbers 0-128. Now add 128 to each (and divide to put into [0,1]).
    32. 

  32. : programme-colour ( l -- colour )
    33. 

  33.     channel>> reverse hashcode
    34. 

  34.     { HEX: 7f HEX: 3fff HEX: 1fffff } [ mask ] with map
    35. 

  35.     { 0 -7 -14 } [ shift 128 + 256 /f ] 2map
    36. 

  36.     first3 1 <rgba> ;
    37. 

  37. 

  38. : output-categories ( l -- )
    39. 

  39.     { { wrap-margin 500 } { inset { 10 0 } } } swap
    40. 

  40.     categories>> [    
    41. 

  41.         [
    42. 

  42.             "\n" append { { font-size 12 } } format
    43. 

  43.         ] each
    44. 

  44.     ] curry with-nesting ;
    45. 

  45. 

  46. :: output-programme ( l -- )
    47. 

  47.     { { wrap-margin 500 } { inset { 5 0 } } }
    48. 

  48.     [
    49. 

  49.         l name>> { { font-size 17 } } format
    50. 

  50.         l channel>> " (from " ")" surround
    51. 

  51.         { { font-size 15 } } format
    52. 

  52.     ] with-nesting
    53. 

  53.     nl
    54. 

  54.     { { wrap-margin 500 } { inset { 10 0 } } }
    55. 

  55.     [
    56. 

  56.         l episode>> { { font-size 15 } } format
    57. 

  57.         nl
    58. 

  58.         "Added: " l timeadded>> file-time-string append
    59. 

  59.         { { font-size 15 } } format
    60. 

  60.     ] with-nesting
    61. 

  61.     nl
    62. 

  62.     { { wrap-margin 500 } { inset { 20 6 } } }
    63. 

  63.     [ l description>> { { font-size 14 } } format ] with-nesting
    64. 

  64.     nl
    65. 

  65.     l output-categories ;
    66. 

  66. 

  67. : <program-gadget> ( listing -- gadget )
    68. 

  68.     dup [ output-programme ] make-pane
    69. 

  69.         swap programme-colour <solid> >>interior ;
    70. 

  70. 

  71. : pl-child-gadgets ( model -- gadgets )
    72. 

  72.     value>> dup empty?
    73. 

  73.     [ drop <noprogrammes-gadget> 1array ]
    74. 

  74.     [ [ 10 0 ] dip kth-page [ <program-gadget> ] map ] if ;
    75. 

  75. 

  76. M: programme-list model-changed
    77. 

  77.     [ clear-gadget ] keep swap pl-child-gadgets add-gadgets drop ;
    78.