RosettaCodeData/Task/Fibonacci-word/PureBasic/fibonacci-word.basic

36 lines
1.0 KiB
Plaintext

EnableExplicit
Define fwx$, n.i
NewMap uchar.i()
Macro RowPrint(ns,ls,es,ws)
Print(RSet(ns,4," ")+RSet(ls,12," ")+" "+es+" ") : If Len(ws)<55 : PrintN(ws) : Else : PrintN("...") : EndIf
EndMacro
Procedure.d nlog2(x.d) : ProcedureReturn Log(x)/Log(2) : EndProcedure
Procedure countchar(s$, Map uchar())
If Len(s$)
uchar(Left(s$,1))=CountString(s$,Left(s$,1)) : s$=RemoveString(s$,Left(s$,1))
ProcedureReturn countchar(s$, uchar())
EndIf
EndProcedure
Procedure.d ce(fw$)
Define e.d
Shared uchar()
countchar(fw$,uchar())
ForEach uchar() : e-uchar()/Len(fw$)*nlog2(uchar()/Len(fw$)) : Next
ProcedureReturn e
EndProcedure
Procedure.s fw(n.i,a$="0",b$="1",m.i=2)
Select n : Case 1 : ProcedureReturn a$ : Case 2 : ProcedureReturn b$ : EndSelect
If m<n : ProcedureReturn fw(n,b$+a$,a$,m+1) : EndIf
ProcedureReturn Mid(a$,3)+ReverseString(Left(a$,2))
EndProcedure
OpenConsole()
PrintN(" N Length Entropy Word")
For n=1 To 37 : fwx$=fw(n) : RowPrint(Str(n),Str(Len(fwx$)),StrD(ce(fwx$),15),fwx$) : Next
Input()