Paste: determinant

Author:	zzing
Mode:	factor
Date:	Thu, 23 Sep 2010 18:24:11

Plain Text |

Delete Paste

! Copyright (C) 2010 Jeffrey Drake.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences locals compiler.tree.propagation.constraints math ; 

IN: opengl1

!  a b c   0 1 2
!  d e f   3 4 5
!  g h i   6 7 8

!   det (A) = aei + bfg + cdh − afh − bdi − ceg.

: 33matrix? ( seq -- ? ) 
    8 swap bounds-check? ;
    
ERROR: not-33matrix seq ;
    
:: det ( matrix -- x )
    matrix 33matrix? =f [ not-33matrix ]
    [ ( -- aei ) matrix 0 4 8 nths * *
      ( -- bfg ) matrix 1 5 6 nths * *
      ( -- cdh ) matrix 2 3 7 nths * * 
      ( aei bfg cdh -- sum ) + +
      ( -- afh ) matrix 0 5 7 nths * *
      ( -- bdi ) matrix 1 3 8 nths * *
      ( -- ceg ) matrix 2 4 6 nths * *
      ( afh bdi ceg -- sum ) + +
      ( sum sum -- det ) - ] if ;

Annotation: locals cleanup

Author:	erg
Mode:	factor
Date:	Thu, 23 Sep 2010 18:31:08

Plain Text |

Delete Annotation

: 33matrix? ( seq -- ? ) 
    8 swap bounds-check? ;
    
ERROR: not-33matrix seq ;
    
:: det ( matrix -- x )
    matrix 33matrix? not [ matrix not-33matrix ]
    [
        matrix { 0 4 8 } nths product
        matrix { 1 5 6 } nths product
        matrix { 2 3 7 } nths product + +
        matrix { 0 5 7 } nths product
        matrix { 1 3 8 } nths product
        matrix { 2 4 6 } nths product + + -
    ] if ;

Annotation: no locals

Author:	erg
Mode:	factor
Date:	Thu, 23 Sep 2010 18:32:38

Plain Text |

Delete Annotation

: 33matrix? ( seq -- ? ) 
    8 swap bounds-check? ;
    
ERROR: not-33matrix seq ;
    
: det ( matrix -- x )
    dup 33matrix? not [ not-33matrix ]
    [
        {
            [ { 0 4 8 } nths product ]
            [ { 1 5 6 } nths product ]
            [ { 2 3 7 } nths product + + ]
            [ { 0 5 7 } nths product ]
            [ { 1 3 8 } nths product ]
            [ { 2 4 6 } nths product + + - ]
        } cleave
    ] if ;

Annotation: ..

Author:	erg
Mode:	factor
Date:	Thu, 23 Sep 2010 18:59:38

Plain Text |

Delete Annotation

: det ( matrix -- x )
    dup 33matrix? not [ not-33matrix ]
    [
        {
            [ [ { 0 4 8 } ] dip nths product ]
            [ [ { 1 5 6 } ] dip nths product ]
            [ [ { 2 3 7 } ] dip nths product + + ]
            [ [ { 0 5 7 } ] dip nths product ]
            [ [ { 1 3 8 } ] dip nths product ]
            [ [ { 2 4 6 } ] dip nths product + + - ]
        } cleave
    ] if ;

Annotation: cross product

Author:	zzing
Mode:	factor
Date:	Thu, 23 Sep 2010 19:40:53

Plain Text |

Delete Annotation

:: cross-product ( a b -- vec )
    a 31matrix?
    b 31matrix? and not [ a b not-31matrix ]
    [ {
    	[ { 1 0 0 } a b 3append det ]
    	[ { 0 1 0 } a b 3append det ]
    	[ { 0 0 1 } a b 3append det ]
      } ... ] if ;

Annotation: other ways

Author:	mrjbq7
Mode:	factor
Date:	Thu, 23 Sep 2010 19:48:31

Plain Text |

Delete Annotation

:: cross-product ( a b -- vec )
    a 31matrix?
    b 31matrix? and not [ a b not-31matrix ]
    [
        {
            [ { 1 0 0 } a b 3append det ]
            [ { 0 1 0 } a b 3append det ]
            [ { 0 0 1 } a b 3append det ]
        } [ call( -- x ) ] map
    ] if ;



:: cross-product ( a b -- vec )
    a 31matrix?
    b 31matrix? and not [ a b not-31matrix ]
    [
        [
            { 1 0 0 } a b 3append det
            { 0 1 0 } a b 3append det
            { 0 0 1 } a b 3append det
        ] output>array
    ] if ;



:: cross-product ( a b -- vec )
    a 31matrix?
    b 31matrix? and not [ a b not-31matrix ]
    [
        { 1 0 0 } a b 3append det
        { 0 1 0 } a b 3append det
        { 0 0 1 } a b 3append det
        3array
    ] if ;



:: cross-product ( a b -- vec )
    a 31matrix?
    b 31matrix? and not [ a b not-31matrix ]
    [
        { { 1 0 0 } { 0 1 0 } { 0 0 1 } } [ a b 3append det ] map
    ] if ;

New Annotation

Summary:
Author:
Mode:	textPostgreSQLPowerCenter Parameter Fileactionscriptadaada95ans-forth94antantlrantlr4apacheconfapdlapplescriptaspaspect-jassembly-agcassembly-agsassembly-arm32assembly-m68kassembly-macro32assembly-mcs51assembly-parrotassembly-r2000assembly-x86avroawkbbatchbbjbcelbeanshellbibtexbinsource-agccc#c++cfscriptchillcilclipsclojurecmakecobolcoffeescriptcoldfusioncplex-lpcsscsvcvs-commitddartdjangodockerfiledotdoxygendrawj2ddsssleiffelembperlerlangfactorfhtmlforthfortranfortran90foxprofreemarkergcbasicgettextgherkingnuplotgogradlegroovygsphaskellhaxehexhl7v2hlslhtaccesshtmlhxmli4glicalendariconidlinforminiinno-setupinterlisiojamonjavajava module-infojavaccjavafxjavascriptjcljedit-actionsjflexjhtmljmkjsonjspkotlinlatexlexlilypondlispliterate-haskelllogslogtalklotosluam4macroschedulermailmakefilemaplemarkdownmavenmavscriptmetapostmlmodula3moinmqscmustache-templatemxmlmyghtymysqln3netrexxnqcnsis2objective-cobjectrexxoccamomnimarkopensipsoutlinepascalpatchperlphppikepl-sqlpl-sql9pl1plaintexplantumlpop11postscriptpovraypowerdynamopowershellprogressprologpropertiesprotobufpspptlpurepvwavepyrexpythonqdocrakefilercprdrebolredcoderelax-ng-compactrenderman-ribrestrfcrhtmlroffrpm-specrtfrubyrustrviews#s+sassbtscalaschemesdl/prsgmlshellscriptshtmlsipsippslateslaxsmalltalksmartysmi-mibsparqlsql-loadersqrsquidconfstatasvn-commitswiftswigtcltemplate-toolkittextexinfotldtransact-sqltsptwikityposcripturluscriptvalavbscriptvelocityverilogvhdlvisualbasicvrml2wellknowntextxmlxqxslyabyamlzpt
Body:

Done