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

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