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

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