extra/recipes/recipes.factor

   1 USING: accessors arrays colors combinators db.sqlite db.tuples
   2 db.types io.files.temp kernel locals math models.combinators
   3 monads persistency sequences sequences.extras sets ui
   4 ui.gadgets.controls ui.gadgets.labels ui.gadgets.layout
   5 ui.gadgets.scrollers ui.pens.solid ;
   6 IN: recipes
   7
   8 STORED-TUPLE: recipe
   9     { title { VARCHAR 100 } }
  10     { votes INTEGER }
  11     { txt TEXT }
  12     { genre { VARCHAR 100 } } ;
  13
  14 : <recipe> ( title genre text -- recipe )
  15     recipe new swap >>txt swap >>genre swap >>title 0 >>votes ;
  16
  17 : init-recipe-db ( -- )
  18     "recipes.db" temp-file <sqlite-db> recipe define-db ;
  19
  20 : top-recipes ( offset search -- recipes )
  21     <query> T{ recipe } rot >>title >>tuple
  22     "votes" >>order 30 >>limit swap >>offset get-tuples ;
  23
  24 : top-genres ( -- genres )
  25     f f top-recipes [ genre>> ] map members 4 index-or-length head-slice ;
  26
  27 : interface ( -- book )
  28     [
  29         [
  30             [ $ TOOLBAR $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
  31             [ "Genres:" <label> , <spacer> $ ALL $ $ GENRES $ ] <hbox>
  32             { 5 0 } >>gap COLOR: gray <solid> >>interior ,
  33             $ RECIPES $
  34         ] <vbox> ,
  35         [
  36             [ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
  37             $ BODY $
  38             $ BUTTON $
  39         ] <vbox> ,
  40     ] <book*> { 350 245 } >>pref-dim ;
  41
  42 :: <recipe-gadget> ( -- gadget )
  43     [
  44         interface
  45         <table*> :> tbl
  46         "okay" <model-border-btn> BUTTON -> :> ok
  47         IMG-MODEL-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
  48         IMG-MODEL-BTN: love 1 >>value TOOLBAR ->
  49         IMG-MODEL-BTN: hate -1 >>value -> 2array merge :> votes
  50         IMG-MODEL-BTN: back -> [ -30 ] <$
  51         IMG-MODEL-BTN: more -> [ 30 ] <$ 2array merge :> viewed
  52         <spacer> <model-field*> ->% 1 :> search
  53         submit ok [ [ drop ] ] <$ 2array merge [ drop ] >>value :> quot
  54         viewed 0 [ + ] fold search ok t <basic> "all" <model-btn> ALL ->
  55         tbl selection>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
  56         4array merge
  57         [ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap :> ups
  58         ups [ top-genres [ <model-btn> GENRES -> ] map merge ] bind*
  59         [ text>> T{ recipe } swap >>genre get-tuples ] fmap
  60         tbl swap ups 2merge >>model
  61         [ [ title>> ] [ genre>> ] bi 2array ] >>quot
  62         { "Title" "Genre" } >>column-titles dup <scroller> RECIPES ,% 1 actions>>
  63         submit [ "" dup dup <recipe> ] <$ 2array merge
  64         {
  65             [ [ title>> ] fmap <model-field> TITLE ->% .5 ]
  66             [ [ genre>> ] fmap <model-field> GENRE ->% .5 ]
  67             [ [ txt>> ] fmap <model-editor> BODY ->% 1 ]
  68         } cleave
  69         [ <recipe> ] 3fmap
  70         [ [ 1 ] <$ ]
  71         [ quot ok updates #1 [ call( recipe -- ) 0 ] 2fmap ] bi
  72         2merge 0 <basic> switch-models >>model
  73     ] with-interface ;
  74
  75 MAIN-WINDOW: recipe-browser
  76     { { title "Recipes" } }
  77     init-recipe-db <recipe-gadget> >>gadgets ;