unmaintained/gml/printer/printer.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 USING: accessors arrays assocs classes gml.runtime gml.types
   3 hashtables io io.styles kernel math math.parser math.vectors.simd
   4 math.vectors.simd.cords sequences strings colors ;
   5 IN: gml.printer
   6
   7 GENERIC: write-gml ( obj -- )
   8
   9 M: object write-gml "«Object: " write name>> write "»" write ;
  10 M: integer write-gml number>string write ;
  11 M: float write-gml number>string write ;
  12 M: string write-gml "\"" write write "\"" write ;
  13 M: name write-gml "/" write string>> write ;
  14 M: exec-name write-gml name>> string>> write ;
  15 M: pathname write-gml names>> [ "." write string>> write ] each ;
  16 M: use-registers write-gml drop "usereg" write ;
  17 M: read-register write-gml ";" write name>> write ;
  18 M: exec-register write-gml ":" write name>> write ;
  19 M: write-register write-gml "!" write name>> write ;
  20
  21 : write-vector ( vec n -- )
  22     head-slice
  23     "(" write [ "," write ] [ number>string write ] interleave ")" write ;
  24 M: double-2 write-gml 2 write-vector ;
  25
  26 M: array write-gml
  27     "[" write [ bl ] [ write-gml ] interleave "]" write ;
  28 M: proc write-gml
  29     "{" write array>> [ bl ] [ write-gml ] interleave "}" write ;
  30 M: hashtable write-gml
  31     "«Dictionary with " write
  32     assoc-size number>string write
  33     " entries»" write ;
  34
  35 : print-gml ( obj -- ) write-gml nl ;
  36
  37 CONSTANT: vertex-colors
  38     {
  39         T{ rgba f   0.   0. 2/3. 1. }
  40         T{ rgba f   0. 2/3.   0. 1. }
  41         T{ rgba f   0. 2/3. 2/3. 1. }
  42         T{ rgba f 2/3.   0.   0. 1. }
  43         T{ rgba f 2/3.   0. 2/3. 1. }
  44         T{ rgba f 2/3. 1/3.   0. 1. }
  45         T{ rgba f   0.   0.   1. 1. }
  46         T{ rgba f   0.   1.   0. 1. }
  47         T{ rgba f   0.   1.   1. 1. }
  48         T{ rgba f   1.   0.   0. 1. }
  49         T{ rgba f   1.   0.   1. 1. }
  50         T{ rgba f   1.   1.   0. 1. }
  51     }
  52
  53 : vertex-color ( position -- rgba )
  54     first3 [ [ >float double>bits ] [ >integer ] bi + ] tri@
  55     bitxor bitxor vertex-colors length mod vertex-colors nth ;
  56
  57 : vertex-style ( position -- rgba )
  58     vertex-color foreground associate ;
  59
  60 M: double-4 write-gml dup vertex-style [ 3 write-vector ] with-style ;