extra/math/affine-transforms/affine-transforms.factor

   1 ! (c)2009 Joe Groff, see BSD license
   2 USING: accessors arrays combinators combinators.short-circuit kernel
   3 math math.functions math.vectors sequences ;
   4 IN: math.affine-transforms
   5
   6 TUPLE: affine-transform
   7     { x read-only }
   8     { y read-only }
   9     { origin read-only } ;
  10 C: <affine-transform> affine-transform
  11
  12 CONSTANT: identity-transform T{ affine-transform f
  13                                 { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } }
  14
  15 : axes ( a -- a' )
  16      [ x>> ] [ y>> ] bi { 0.0 0.0 } <affine-transform> ;
  17
  18 : a.v ( a v -- v )
  19     [ [ x>> ] [ first  ] bi* v*n ]
  20     [ [ y>> ] [ second ] bi* v*n ]
  21     [ drop origin>> ] 2tri
  22     v+ v+ ;
  23
  24 : <identity> ( -- a )
  25     { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> ;
  26 : <translation> ( origin -- a )
  27     [ { 1.0 0.0 } { 0.0 1.0 } ] dip <affine-transform> ;
  28 : <rotation> ( theta -- transform )
  29     [ cos ] [ sin ] bi
  30     [ 2array ] [ neg swap 2array ] 2bi { 0.0 0.0 } <affine-transform> ;
  31 : <scale> ( x y -- transform )
  32     [ 0.0 2array ] [ 0.0 swap 2array ] bi* { 0.0 0.0 } <affine-transform> ;
  33
  34 : center-rotation ( transform center -- transform )
  35     [ [ x>> ] [ y>> ] [ ] tri ] dip [ vneg a.v ] [ v+ ] bi
  36     <affine-transform> ;
  37
  38 : flatten-transform ( transform -- array )
  39     [ x>> ] [ y>> ] [ origin>> ] tri 3append ;
  40
  41 : |a| ( a -- det )
  42     [ [ x>> first  ] [ y>> second ] bi * ]
  43     [ [ x>> second ] [ y>> first  ] bi * ] bi - ;
  44
  45 : (inverted-axes) ( a -- x y )
  46     [ [ y>> second     ] [ x>> second neg ] bi 2array ]
  47     [ [ y>> first  neg ] [ x>> first      ] bi 2array ]
  48     [ |a| ] tri
  49     [ v/n ] curry bi@ ;
  50
  51 : inverse-axes ( a -- a^-1 )
  52     (inverted-axes) { 0.0 0.0 } <affine-transform> ;
  53
  54 : inverse-transform ( a -- a^-1 )
  55     [ inverse-axes [ x>> ] [ y>> ] [ ] tri ] [ origin>> ] bi
  56     a.v vneg <affine-transform> ;
  57
  58 : transpose-axes ( a -- a^T )
  59     [ [ x>> first  ] [ y>> first  ] bi 2array ]
  60     [ [ x>> second ] [ y>> second ] bi 2array ]
  61     [ origin>> ] tri <affine-transform> ;
  62
  63 : a. ( a a -- a )
  64     {
  65         [ [ transpose-axes x>> ] [ x>> ] bi* vdot ]
  66         [ [ transpose-axes y>> ] [ x>> ] bi* vdot ]
  67         [ [ transpose-axes x>> ] [ y>> ] bi* vdot ]
  68         [ [ transpose-axes y>> ] [ y>> ] bi* vdot ]
  69         [ origin>> a.v ]
  70     } 2cleave
  71     [ [ 2array ] 2bi@ ] dip <affine-transform> ;
  72
  73 : a~ ( a b epsilon -- ? )
  74     {
  75         [ [ [ x>>      ] bi@ ] dip v~ ]
  76         [ [ [ y>>      ] bi@ ] dip v~ ]
  77         [ [ [ origin>> ] bi@ ] dip v~ ]
  78     } 3&& ;