basis/ui/gadgets/debug/debug.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays colors.constants combinators kernel
   4 opengl sequences ui ui.baseline-alignment ui.gadgets
   5 ui.gadgets.buttons ui.gadgets.labels ui.pens ui.render ui.text ;
   6 IN: ui.gadgets.debug
   7
   8 TUPLE: baseline-gadget < gadget baseline cap-height ;
   9
  10 M: baseline-gadget baseline baseline>> ;
  11
  12 M: baseline-gadget cap-height cap-height>> ;
  13
  14 : <baseline-gadget> ( baseline cap-height dim -- gadget )
  15     baseline-gadget new
  16         swap >>dim
  17         swap >>cap-height
  18         swap >>baseline ;
  19
  20 ! An intentionally broken gadget -- used to test UI error handling,
  21 ! make sure that one bad gadget doesn't bring the whole system down
  22
  23 : <bad-button> ( -- button )
  24     "Click me if you dare"
  25     [ "Haha" throw ]
  26     <border-button> ;
  27
  28 TUPLE: bad-gadget < gadget ;
  29
  30 M: bad-gadget draw-gadget* "Lulz" throw ;
  31
  32 M: bad-gadget pref-dim* drop { 100 100 } ;
  33
  34 : <bad-gadget> ( -- gadget ) bad-gadget new ;
  35
  36 : bad-gadget-test ( -- )
  37     <bad-button> "Test 1" open-window
  38     <bad-gadget> "Test 2" open-window ;
  39
  40 SINGLETON: metrics-paint
  41
  42 M: metrics-paint draw-boundary
  43     drop
  44     COLOR: red gl-color
  45     [ dim>> ] [ >label< line-metrics ] bi
  46     [ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ]
  47     [ drop gl-rect ]
  48     2bi ;
  49
  50 : <metrics-gadget> ( text font -- gadget )
  51     [ <label> ] dip >>font metrics-paint >>boundary ;