extra/hats/hats.factor

   1 ! Copyright (C) 2008 Alex Chapman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors boxes kernel namespaces ;
   4 IN: hats
   5
   6 ! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat!
   7 ! Rocky: But that trick never works!
   8 ! Bullwinkle: This time for sure!
   9
  10 ! hat protocol
  11 MIXIN: hat
  12
  13 GENERIC: out ( hat -- object )
  14 GENERIC: (in) ( object hat -- )
  15
  16 : in ( hat object -- hat ) over (in) ; inline
  17 : empty-hat? ( hat -- ? ) out not ; inline
  18 : empty-hat ( hat -- hat ) f in ; inline
  19 : take ( hat -- object ) dup out f rot (in) ; inline
  20 : change-hat ( hat quot -- hat )
  21     over >r >r out r> call r> swap in ; inline
  22
  23 ! caps (the simplest of hats)
  24 TUPLE: cap object ;
  25 C: <cap> cap
  26 M: cap out ( cap -- object ) object>> ;
  27 M: cap (in) ( object cap -- ) (>>object) ;
  28 INSTANCE: cap hat
  29
  30 ! bowlers (dynamic variable hats)
  31 TUPLE: bowler variable ;
  32 C: <bowler> bowler
  33 M: bowler out ( bowler -- object ) variable>> get ;
  34 M: bowler (in) ( object bowler -- ) variable>> set ;
  35 INSTANCE: bowler hat
  36
  37 ! Top Hats (global variable hats)
  38 TUPLE: top-hat variable ;
  39 C: <top-hat> top-hat
  40 M: top-hat out ( top-hat -- object ) variable>> get-global ;
  41 M: top-hat (in) ( object top-hat -- ) variable>> set-global ;
  42 INSTANCE: top-hat hat
  43
  44 USE: slots.private
  45 ! Slot hats
  46 TUPLE: slot-hat tuple slot ;
  47 C: <slot-hat> slot-hat
  48 : >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
  49 M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ;
  50 M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ;
  51 INSTANCE: slot-hat hat
  52
  53 ! Put a box on your head
  54 M: box out ( box -- object ) box> ;
  55 M: box (in) ( object box -- ) >box ;
  56 INSTANCE: box hat
  57