Paste: 215

Author:	glguy
Mode:	factor
Date:	Sun, 9 Nov 2008 07:23:34

Plain Text |

Delete Paste

USING: kernel math arrays sequences combinators ;
IN: project-euler.215

: firstTree ( n -- t )
  [ 0 1 0 ] dip
  1- [ dupd 2array -rot ] times 2drop ;

: total ( t -- n )
  dup array? [ [ total ] sigma ] when ;

: merge ( t t -- t )
  {
    { [ 2dup [ array? ] both? ] [ [ first2 ] bi@ swapd [ merge ] 2bi@ 2array ] }
    { [ 2dup [ integer? ] both? ] [ + ] }
    { [ dup 0 = ] [ drop ] }
    [ nip ]
  } cond ;

DEFER: h-1
DEFER: h0
DEFER: h1
DEFER: h2

: choice ( t p q -- t t )
  [ first2 ] 2dip bi* ;

: stepper ( t -- t )
  [ h-1 ] [ h1 ] choice swap 2array ;

: h-1 ( t -- t )
  dup array? [
    [ h1 ] [ h2 ] choice merge
  ] [
    drop 0
  ] if ;

: h0 ( t -- t )
  dup integer? [ drop 0 ] unless ;

: h1 ( t -- t )
  dup array? [
    [ [ h1 ] [ h2 ] choice merge ]
    [ [ h0 ] [ h1 ] choice merge ] bi 2array
  ] [
    drop 0
  ] if ;

: h2 ( t -- t )
  {
    { [ dup array? ] [ [ h1 ] [ h2 ] choice merge 0 swap 2array ] }
    { [ dup zero? ] [ ] }
    [ 0 2array ]
  } cond ;

: solve-215 ( width height -- ways )
  [ firstTree ] dip 1- [ stepper ] times total ;

Annotation: 215 with generics and tuples

Author:	glguy
Mode:	factor
Date:	Sun, 9 Nov 2008 12:27:33

Plain Text |

Delete Annotation

USING: kernel math sequences combinators accessors ;
IN: project-euler.215

TUPLE: node two three ;
TUPLE: term { count integer } ;

: <node> ( l r -- t ) node boa ; inline
: <term> ( n -- t ) term boa ; inline
: <failure> ( -- t ) 0 <term> ; inline
: <success> ( -- t ) 1 <term> ; inline

: failure? ( t -- ? ) count>> zero? ; inline

: add-terms ( t t -- t ) [ count>> ] bi@ + <term> ; inline

: choice ( t p q -- t t )
  [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline

GENERIC: total ( t -- n )
M: node total [ total ] dup choice + ;
M: term total count>> ;

: merge ( t t -- t )
   2dup [ node? ] bi@ [
     [ [ [ two>>   ] bi@ merge ]
       [ [ three>> ] bi@ merge ] 2bi <node>
     ] [ nip ] if
   ] [
     [ drop ] [ add-terms ] if
   ] if ;


GENERIC: h-1 ( t -- t )
GENERIC: h0 ( t -- t )
GENERIC: h1 ( t -- t )
GENERIC: h2 ( t -- t )

M: node h-1 [ h1 ] [ h2 ] choice merge ;
M: term h-1 drop <failure> ;

M: node h0 drop <failure> ;
M: term h0 ;

M: node h1 
    [ [ h1 ] [ h2 ] choice merge ]
    [ [ h0 ] [ h1 ] choice merge ] bi <node> ;
M: term h1 drop <failure> ;

M: node h2 [ h1 ] [ h2 ] choice merge <failure> swap <node> ;
M: term h2 dup failure? [ <failure> <node> ] unless ;

: stepper ( t -- t )
  [ h-1 ] [ h1 ] choice swap <node> ;

: first-row ( n -- t )
  [ <failure> <success> <failure> ] dip
  1- [ over roll <node> ] times 2nip ;

: solve-215 ( width height -- ways )
  [ first-row ] dip 1- [ stepper ] times total ;

Annotation: revision

Author:	glguy
Mode:	factor
Date:	Mon, 10 Nov 2008 00:02:06

Plain Text |

Delete Annotation

USING: accessors kernel math ;
IN: project-euler.215

TUPLE: block two three ;
TUPLE: end { ways integer } ;

: <block> ( l r -- t ) block boa ; inline
: <end> ( n -- t ) end boa ; inline
: <failure> end new ; inline
: <success> 1 <end> ; inline

: failure? ( t -- ? ) ways>> zero? ; inline

: add-ends ( t t -- t ) [ ways>> ] bi@ + <end> ; inline

: choice ( t p q -- t t ) [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline

: merge ( t t -- t )
   over block? over block? [
     [ [ [ two>>   ] bi@ merge ]
       [ [ three>> ] bi@ merge ] 2bi <block>
     ] [ nip ] if
   ] [
     [ drop ] [ add-ends ] if
   ] if ;

GENERIC: h-1 ( t -- t )
GENERIC: h0 ( t -- t )
GENERIC: h1 ( t -- t )
GENERIC: h2 ( t -- t )

M: block h-1 [ h1 ] [ h2 ] choice merge ;
M: block h0 drop <failure> ;
M: block h1 [ [ h1 ] [ h2 ] choice merge ]
            [ [ h0 ] [ h1 ] choice merge ] bi <block> ;
M: block h2 [ h1 ] [ h2 ] choice merge <failure> swap <block> ;

M: end h-1 drop <failure> ;
M: end h0 ;
M: end h1 drop <failure> ;
M: end h2 dup failure? [ <failure> <block> ] unless ;

: next-row [ h-1 ] [ h1 ] choice swap <block> ;

: first-row
  [ <failure> <success> <failure> ] dip
  1- [ over roll <block> ] times 2nip ;

GENERIC: total ( t -- n )
M: block total [ total ] dup choice + ;
M: end   total ways>> ;

: solve ( width height -- ways )
  [ first-row ] dip 1- [ next-row ] times total ;

: euler215 32 10 solve ;

Annotation: in haskell

Author:	glguy
Mode:	haskell
Date:	Mon, 10 Nov 2008 00:16:59

Plain Text |

Delete Annotation

module Main where

import System.Environment (getArgs)

data Trie = !Trie :+ !Trie | End !Integer

first                   = go (End 0) (End 1) (End 0)
  where go a _ _ 1      = a
        go a b c n      = go (b :+ c) a b (n-1)

(l1 :+ r1) & (l2 :+ r2) = (l1 & l2) :+ (r1 & r2)
End a      & End b      = End (a + b)
t          & End _      = t
_          & t          = t

count (l :+ r)          = count l + count r
count (End n)           = n

step (l :+ r)           = h1 r :+ h_1 l
  where
  h_1 (l :+ r)          = h1 l & h2 r
  h_1 _                 = End 0

  h0 (End n)            = End n
  h0 _                  = End 0

  h1 (l :+ r)           = (h1 l & h2 r) :+ (h0 l & h1 r)
  h1 _                  = End 0

  h2 (End 0)            = End 0
  h2 (End n)            = End n :+ End 0
  h2 (l :+ r)           = End 0 :+ (h1 l & h2 r)
step x                  = x

solve w h               = count (iterate step (first w) !! (h-1))

main = do
  [x,y] <- mapM readIO =<< getArgs
  print (solve x y)

Annotation: GENERIC merge implementation

Author:	glguy
Mode:	factor
Date:	Mon, 10 Nov 2008 00:35:47

Plain Text |

Delete Annotation

USING: accessors kernel locals math ;
IN: project-euler.215

TUPLE: block two three ;
TUPLE: end { ways integer } ;

C: <block> block
C: <end> end
: <failure> 0 <end> ; inline
: <success> 1 <end> ; inline

: failure? ( t -- ? ) ways>> 0 = ; inline

: choice ( t p q -- t t ) [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline

GENERIC# merge 1 ( t t -- t )
GENERIC: block-merge ( t t -- t )
GENERIC: end-merge ( t t -- t )
M: block merge block-merge ;
M: end   merge end-merge ;
M: block block-merge [ [ two>>   ] bi@ merge ]
                     [ [ three>> ] bi@ merge ] 2bi <block> ;
M: end   block-merge nip ;
M: block end-merge drop ;
M: end   end-merge [ ways>> ] bi@ + <end> ;

GENERIC: h-1 ( t -- t )
GENERIC: h0 ( t -- t )
GENERIC: h1 ( t -- t )
GENERIC: h2 ( t -- t )

M: block h-1 [ h1 ] [ h2 ] choice merge ;
M: block h0 drop <failure> ;
M: block h1 [ [ h1 ] [ h2 ] choice merge ]
            [ [ h0 ] [ h1 ] choice merge ] bi <block> ;
M: block h2 [ h1 ] [ h2 ] choice merge <failure> swap <block> ;

M: end h-1 drop <failure> ;
M: end h0 ;
M: end h1 drop <failure> ;
M: end h2 dup failure? [ <failure> <block> ] unless ;

: next-row ( t -- t ) [ h-1 ] [ h1 ] choice swap <block> ;

: first-row ( n -- t )
  [ <failure> <success> <failure> ] dip
  1- [| a b c | b c b a <block> ] times 2nip ;

GENERIC: total ( t -- n )
M: block total [ total ] dup choice + ;
M: end   total ways>> ;

: solve ( width height -- ways )
  [ first-row ] dip 1- [ next-row ] times total ;

: euler215 ( -- ways ) 32 10 solve ;

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