June 2018 Update

Task/Fibonacci-word/Factor/fibonacci-word.factor

@@ -0,0 +1,36 @@
+USING: assocs combinators formatting kernel math math.functions
+math.ranges math.statistics namespaces pair-rocket sequences ;
+IN: rosetta-code.fibonacci-word
+
+SYMBOL: 37th-fib-word
+
+: fib ( n -- m )
+    {
+        1 => [ 1 ]
+        2 => [ 1 ]
+        [ [ 1 - fib ] [ 2 - fib ] bi + ]
+    } case ;
+
+: fib-word ( n -- seq )
+    {
+        1 => [ "1" ]
+        2 => [ "0" ]
+        [ [ 1 - fib-word ] [ 2 - fib-word ] bi append ]
+    } case ;
+
+: nth-fib-word ( n -- seq )
+    dup 1 =
+    [ drop "1" ] [ 37th-fib-word get swap fib head ] if ;
+
+: entropy ( seq -- entropy )
+    [ length ] [ histogram >alist [ second ] map ] bi
+    [ swap / ] with map
+    [ dup log 2 log / * ] map-sum
+    dup 0. = [ neg ] unless ;
+
+37 fib-word 37th-fib-word set
+"N" "Length" "Entropy" "%2s  %8s  %10s\n" printf
+37 [1,b] [
+   dup nth-fib-word [ length ] [ entropy ] bi
+   "%2d  %8d  %.8f\n" printf
+] each