    P =8
    S  =int( log( P) /log( 2) +0.9999)

    Pi =3.14159265
    R1 =2^S

    R =R1 -1
    R2 =div( R1,  2)
    R4 =div( R1,  4)
    R3 =R4 +R2

    Dim Re( R1), Im( R1), Co( R3)

    for N =0 to P -1
        read dummy: Re( N) =dummy
        read dummy: Im( N) =dummy
    next N

    data    1, 0,      1, 0,      1, 0,      1, 0,      0, 0,     0, 0,      0, 0,       0, 0

    S2 =div( S, 2)
    S1 =S -S2
    P1 =2^S1
    P2 =2^S2

    dim V( P1 -1)
    V( 0) =0
    DV =1
    DP =P1

    for J =1 to S1
        HA =div( DP, 2)
        PT =P1 -HA
        for I =HA to PT step DP
            V( I) =V( I -HA) +DV
        next I
        DV =DV +DV
        DP =HA
    next J

    K =2 *Pi /R1

    for X =0 to R4
        COX =cos( K *X)
        Co( X) =COX
        Co( R2 -X) =0 -COX
        Co( R2 +X) =0 -COX
    next X

    print "FFT: bit reversal"

    for I =0 to P1 -1
        IP =I *P2
        for J =0 to P2 -1
            H =IP +J
            G =V( J) *P2 +V( I)
            if G >H then temp =Re( G): Re( G) =Re( H): Re( H) =temp
            if G >H then temp =Im( G): Im( G) =Im( H): Im( H) =temp
        next J
    next I

    T =1

    for stage =0 to S -1
        print "  Stage:- "; stage
        D =div( R2, T)
        for Z =0 to T -1
            L   =D *Z
            LS  =L +R4
            for I =0 to D -1
                A      =2 *I *T +Z
                B      =A +T
                F1     =Re( A)
                F2     =Im( A)
                P1     =Co( L)  *Re( B)
                P2     =Co( LS) *Im( B)
                P3     =Co( LS) *Re( B)
                P4     =Co( L)  *Im( B)
                Re( A) =F1 +P1 -P2
                Im( A) =F2 +P3 +P4
                Re( B) =F1 -P1 +P2
                Im( B) =F2 -P3 -P4
            next I
        next Z
        T =T +T
    next stage

    print "   M          Re( M)       Im( M)"

    for M =0 to R
        if abs( Re( M)) <10^-5 then Re( M) =0
        if abs( Im( M)) <10^-5 then Im( M) =0
        print "   "; M, Re( M), Im( M)
    next M

    end

    wait

    function div( a, b)
        div =int( a /b)
    end function

    end


*        Fibonacci sequence    05/11/2014
*        integer (31 bits) = 10 decimals -> max fibo(46)
FIBONACC CSECT
         USING FIBONACC,R12    base register
SAVEAREA B     STM-SAVEAREA(R15) skip savearea
         DC    17F'0'          savearea
         DC    CL8'FIBONACC'   eyecatcher
STM      STM   R14,R12,12(R13) save previous context
         ST    R13,4(R15)      link backward
         ST    R15,8(R13)      link forward
         LR    R12,R15         set addressability
*        ----
         LA    R1,0            f(n-2)=0
         LA    R2,1            f(n-1)=1
         LA    R4,2            n=2
         LA    R6,1            step
         LH    R7,NN           limit
LOOP     EQU   *               for n=2 to nn
         LR    R3,R2             f(n)=f(n-1)
         AR    R3,R1             f(n)=f(n-1)+f(n-2)
         CVD   R4,PW             n  convert binary to packed (PL8)
         UNPK  ZW,PW             packed (PL8) to zoned (ZL16)
         MVC   CW,ZW             zoned (ZL16) to  char (CL16)
         OI    CW+L'CW-1,X'F0'   zap sign
         MVC   WTOBUF+5(2),CW+14 output
         CVD   R3,PW             f(n) binary to packed decimal (PL8)
         MVC   ZN,EM             load mask
         ED    ZN,PW             packed dec (PL8) to char (CL20)
         MVC   WTOBUF+9(14),ZN+6 output
         WTO   MF=(E,WTOMSG)     write buffer
         LR    R1,R2             f(n-2)=f(n-1)
         LR    R2,R3             f(n-1)=f(n)
         BXLE  R4,R6,LOOP      endfor n
*        ----
         LM    R14,R12,12(R13) restore previous savearea pointer
         XR    R15,R15         return code set to 0
         BR    R14             return to caller
*        ----  DATA
NN       DC    H'46'           nn max n
PW       DS    PL8             15num
ZW       DS    ZL16
CW       DS    CL16
ZN       DS    CL20
*                  ' b 0 0 0 , 0 0 0 , 0 0 0 , 0 0 0 , 0 0 0'  15num
EM       DC    XL20'402020206B2020206B2020206B2020206B202120'  mask
WTOMSG   DS    0F
         DC    H'80',XL2'0000'
*                   fibo(46)=1836311903
WTOBUF   DC    CL80'fibo(12)=1234567890'
         REGEQU
         END   FIBONACC


-- operations on complex number
complex = {__mt={} }

function complex.new (r, i)
  local new={r=r, i=i or 0}
  setmetatable(new,complex.__mt)
  return new
end

function complex.__mt.__add (c1, c2)
  return complex.new(c1.r + c2.r, c1.i + c2.i)
end

function complex.__mt.__sub (c1, c2)
  return complex.new(c1.r - c2.r, c1.i - c2.i)
end

function complex.__mt.__mul (c1, c2)
  return complex.new(c1.r*c2.r - c1.i*c2.i,
                      c1.r*c2.i + c1.i*c2.r)
end

function complex.expi (i)
  return complex.new(math.cos(i),math.sin(i))
end

function complex.__mt.__tostring(c)
  return "("..c.r..","..c.i..")"
end

-- Cooley–Tukey FFT (in-place, divide-and-conquer)
-- Higher memory requirements and redundancy although more intuitive
function fft(vect)
  local n=#vect
  if n<=1 then return vect end
-- divide
  local odd,even={},{}
  for i=1,n,2 do
    odd[#odd+1]=vect[i]
    even[#even+1]=vect[i+1]
  end
-- conquer
  fft(even);
  fft(odd);
-- combine
  for k=1,n/2 do
    local t=even[k] * complex.expi(-2*math.pi*(k-1)/n)
    vect[k] = odd[k] + t;
    vect[k+n/2] = odd[k] - t;
  end
  return vect
end

function toComplex(vectr)
  vect={}
  for i,r in ipairs(vectr) do
    vect[i]=complex.new(r)
  end
  return vect
end

-- test
data = toComplex{1, 1, 1, 1, 0, 0, 0, 0};

-- this works for old lua versions & luaJIT (depends on version!)
-- print("orig:", unpack(data))
-- print("fft:", unpack(fft(data)))

-- Beginning with Lua 5.2 you have to write
print("orig:", table.unpack(data))
print("fft:", table.unpack(fft(data)))


       LDA  #0
       STA  $F0     ; LOWER NUMBER
       LDA  #1
       STA  $F1     ; HIGHER NUMBER
       LDX  #0
LOOP:  LDA  $F1
       STA  $0F1B,X
       STA  $F2     ; OLD HIGHER NUMBER
       ADC  $F0
       STA  $F1     ; NEW HIGHER NUMBER
       LDA  $F2
       STA  $F0     ; NEW LOWER NUMBER
       INX
       CPX  #$0A    ; STOP AT FIB(10)
       BMI  LOOP
       RTS          ; RETURN FROM SUBROUTINE


with( DiscreteTransforms ):

FourierTransform( <1,1,1,1,0,0,0,0>, normalization=none );


fib:
	MOVEM.L D4-D5,-(SP)
		MOVE.L D0,D4
		MOVEQ #0,D5
		CMP.L #2,D0
		BCS .bar
		MOVEQ #0,D5
.foo:
		MOVE.L D4,D0
		SUBQ.L #1,D0
		JSR fib
		SUBQ.L #2,D4
		ADD.L D0,D5
		CMP.L #1,D4
		BHI .foo
.bar:
		MOVE.L D5,D0
		ADD.L D4,D0
	MOVEM.L (SP)+,D4-D5
	RTS


FIBNCI: MOV  C,  A  ; C will store the counter
        DCR  C      ; decrement, because we know f(1) already
        MVI  A,  1
        MVI  B,  0
LOOP:   MOV  D,  A
        ADD  B      ; A := A + B
        MOV  B,  D
        DCR  C
        JNZ  LOOP   ; jump if not zero
        RET         ; return from subroutine


import math, complex, strutils

# Works with floats and complex numbers as input
proc fft[T: float | Complex[float]](x: openarray[T]): seq[Complex[float]] =
  let n = x.len
  if n == 0: return

  result.newSeq(n)

  if n == 1:
    result[0] = (when T is float: complex(x[0]) else: x[0])
    return

  var evens, odds = newSeq[T]()
  for i, v in x:
    if i mod 2 == 0: evens.add v
    else: odds.add v
  var (even, odd) = (fft(evens), fft(odds))

  let halfn = n div 2

  for k in 0 ..< halfn:
    let a = exp(complex(0.0, -2 * Pi * float(k) / float(n))) * odd[k]
    result[k] = even[k] + a
    result[k + halfn] = even[k] - a

for i in fft(@[1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0]):
  echo formatFloat(abs(i), ffDecimal, 3)


open Complex

let fac k n =
   let m2pi = -4.0 *. acos 0.0 in
   polar 1.0 (m2pi*.(float k)/.(float n))

let merge l r n =
   let f (k,t) x = (succ k, (mul (fac k n) x) :: t) in
   let z = List.rev (snd (List.fold_left f (0,[]) r)) in
   (List.map2 add l z) @ (List.map2 sub l z)

let fft lst =
   let rec ditfft2 a n s =
      if n = 1 then [List.nth lst a] else
      let odd = ditfft2 a (n/2) (2*s) in
      let even = ditfft2 (a+s) (n/2) (2*s) in
      merge odd even n in
   ditfft2 0 (List.length lst) 1;;

let show l =
   let pr x = Printf.printf "(%f %f) " x.re x.im in
   (List.iter pr l; print_newline ()) in
let indata = [one;one;one;one;zero;zero;zero;zero] in
show indata;
show (fft indata)


fib:
; 	WRITTEN IN C WITH X86-64 CLANG 3.3 AND DOWNGRADED TO 16-BIT X86
; 	INPUT: DI = THE NUMBER YOU WISH TO CALC THE FIBONACCI NUMBER FOR.
;	OUTPUTS TO AX

        push    BP
        push    BX
        push    AX
        mov     BX, DI			;COPY INPUT TO BX
        xor     AX, AX			;MOV AX,0
        test    BX, BX			;SET FLAGS ACCORDING TO BX
        je      LBB0_4			;IF BX == 0 RETURN 0
        cmp     BX, 1			;IF BX == 1 RETURN 1
        jne     LBB0_3
        mov     AX, 1			;ELSE, SET AX = 1 AND RETURN
        jmp     LBB0_4
LBB0_3:
        lea     DI, WORD PTR [BX - 1]   ;DI = BX - 1
        call    fib			;RETURN FIB(BX-1)
        mov     BP, AX			;STORE THIS IN BP
        add     BX, -2
        mov     DI, BX
        call    fib			;GET FIB(DI - 2)
        add     AX, BP		        ;RETURN FIB(DI - 1) + FIB(DI - 2)
LBB0_4:

	add sp,2
        pop     BX
        pop     BP
        ret


Numeric Digits 16
list='1 1 1 1 0 0 0 0'
n=words(list)
x=.array~new(n)
Do i=1 To n
  x[i]=.complex~new(word(list,i),0)
  End
Call show 'FFT  in',x
call fft x
Call show 'FFT out',x
Exit

show: Procedure
  Use Arg data,x
  Say '---data---   num       real-part   imaginary-part'
  Say '----------   ---       ---------   --------------'
  Do i=1 To x~size
    say data right(i,7)'       ' x[i]~string
    End
  Return

fft: Procedure
  Use Arg in
  Numeric Digits 16
  n=in~size
  If n=1 Then Return
  odd=.array~new(n/2)
  even=.array~new(n/2)
  Do j=1 To n By 2; odd[(j+1)/2]=in[j]; End
  Do j=2 To n By 2; even[j/2]=in[j]; End
  Call fft odd
  Call fft even
  pi=3.14159265358979323E0
  n_2=n/2
  Do i=1 To n_2
    w=-2*pi*(i-1)/N
    t=.complex~new(rxCalcCos(w,,'R'),rxCalcSin(w,,'R'))*even[i]
    in[i]=odd[i]+t
    in[i+n_2]=odd[i]-t
    End
  Return

::class complex
::method init
  expose r i
  use strict arg r, i = 0

-- complex instances are immutable, so these are
-- read only attributes
::attribute r GET
::attribute i GET

::method add
  expose r i
  Numeric Digits 16
  use strict arg other
  if other~isa(.complex) then
     return self~class~new(r + other~r, i + other~i)
  else return self~class~new(r + other, i)

::method subtract
  expose r i
  Numeric Digits 16
  use strict arg other
  if other~isa(.complex) then
     return self~class~new(r - other~r, i - other~i)
  else return self~class~new(r - other, i)

::method "+"
  Numeric Digits 16
  -- need to check if this is a prefix plus or an addition
  if arg() == 0 then
      return self  -- we can return this copy since it is immutable
  else
      forward message("ADD")

::method "-"
  Numeric Digits 16
  -- need to check if this is a prefix minus or a subtract
  if arg() == 0 then
      forward message("NEGATIVE")
  else
      forward message("SUBTRACT")

::method times
  expose r i
  Numeric Digits 16
  use strict arg other
  if other~isa(.complex) then
     return self~class~new(r * other~r - i * other~i, r * other~i + i * other~r)
  else return self~class~new(r * other, i * other)

::method "*"
  Numeric Digits 16
  forward message("TIMES")

::method string
  expose r i
  Numeric Digits 12
  Select
    When i=0 Then
      If r=0 Then
        Return '0'
      Else
        Return format(r,1,9)
    When i>0 Then
      Return format(r,1,9)' +'format(i,1,9)'i'
    Otherwise
      Return format(r,1,9)' -'format(abs(i),1,9)'i'
    End

::method formatnumber private
  use arg value
  Numeric Digits 16
  if value > 0 then return "+" value
  else return "-" value~abs

::requires rxMath library


: fibon \ n -- fib(n)
  >r 0 1
  ( tuck n:+ ) \ fib(n-2) fib(n-1) -- fib(n-1) fib(n)
  r> n:1- times ;

: fib \ n -- fib(n)
  dup 1 n:= if 1 ;; then
  fibon nip ;


PROGRAM RDFT;

(*)

        Free Pascal Compiler version 3.2.0 [2020/06/14] for x86_64
        The free and readable alternative at C/C++ speeds
        compiles natively to almost any platform, including raspberry PI *
        Can run independently from DELPHI / Lazarus

        For debian Linux: apt -y install fpc
        It contains a text IDE called fp

(*)

USES

    crt,
    math,
    sysutils,
    ucomplex;

TYPE

    table = array  of complex;

PROCEDURE Split ( T: table ; EVENS: table; ODDS:table ) ;

    VAR

        k:  integer ;

    BEGIN

        FOR k := 0 to Length ( T ) - 1 DO

            IF Odd ( k ) THEN

                ODDS [ k DIV 2 ]    := T [ k ]

            ELSE

                EVENS [ k DIV 2 ]   := T [ k ]

    END;

PROCEDURE WriteCTable ( L: table ) ;

    VAR

        x   :integer ;

    BEGIN

        FOR x := 0  to length ( L ) - 1 DO

            BEGIN

                Write   ( Format ('%3.3g ' , [ L [ x ].re ] ) ) ;

                IF ( L [ x ].im >= 0.0 ) THEN Write ( '+' ) ;

                WriteLn ( Format ('%3.5gi' , [ L [ x ].im ] ) ) ;

            END ;

    END;

FUNCTION FFT ( L : table ): table ;

    VAR

        k       :   integer ;
        N       :   integer ;
        halfN   :   integer ;
        E       :   table   ;
        Even    :   table   ;
        O       :   table   ;
        Odds    :   table   ;
        T       :   complex ;

    BEGIN

        N   :=  length ( L )        ;

        IF N < 2 THEN

            EXIT ( L )  ;

        halfN := ( N DIV 2 )        ;

        SetLength ( E,    halfN )   ;

        SetLength ( O,    halfN )   ;

        Split     ( L, E, O )       ;

        SetLength ( L, 0 )   	    ;

        SetLength ( Even, halfN )   ;

        Even :=     FFT ( E )       ;

        SetLength ( E   , 0 )       ;

        SetLength ( Odds, halfN )   ;

        Odds :=     FFT ( O )       ;

        SetLength ( O   , 0 )       ;

        SetLength ( L,    N )       ;

        FOR k := 0 to halfN - 1 DO

            BEGIN

                T               := Cexp ( -2 * i * pi * k / N ) * Odds [ k ];

                L [ k ]         := Even [ k ] + T                      	    ;

                L [ k + halfN ] := Even [ k ] - T                      	    ;

            END ;

        SetLength ( Even, 0 )   ;

        SetLength ( Odds, 0 )   ;

        FFT :=  L               ;

    END ;

VAR

    Ar  :   array of complex ;

    x   :   integer ;

BEGIN

    SetLength ( Ar, 8 ) ;

    FOR x := 0 TO 3 DO

	BEGIN

	    Ar [ x ]        :=  1.0 ;

	    Ar [ x + 4 ]    :=  0.0 ;

	END;

    WriteCTable ( FFT ( Ar ) )  ;

    SetLength ( Ar, 0 ) ;

END.
(*)
    Output:

        4 +  0i
        1 -2.4142i
        0 +  0i
        1 -0.41421i
        0 +  0i
        1 +0.41421i
        0 +  0i
        1 +2.4142i


FORM fibonacci_iter USING index TYPE i
                    CHANGING number_fib TYPE i.
  DATA: lv_old type i,
        lv_cur type i.
  Do index times.
    If sy-index = 1 or sy-index = 2.
      lv_cur = 1.
      lv_old = 0.
    endif.
    number_fib = lv_cur + lv_old.
    lv_old = lv_cur.
    lv_cur = number_fib.
  enddo.
ENDFORM.


(defun fast-fib-r (n a b)
   (if (or (zp n) (zp (1- n)))
       b
       (fast-fib-r (1- n) b (+ a b))))

(defun fast-fib (n)
   (fast-fib-r n 1 1))

(defun first-fibs-r (n i)
   (declare (xargs :measure (nfix (- n i))))
   (if (zp (- n i))
       nil
       (cons (fast-fib i)
             (first-fibs-r n (1+ i)))))

(defun first-fibs (n)
   (first-fibs-r n 0))


--
-- demo\rosetta\FastFourierTransform.exw
-- =====================================
--
--  Originally written by Robert Craig and posted to EuForum Dec 13, 2001
--

constant REAL = 1, IMAG = 2

type complex(sequence x)
    return length(x)=2 and atom(x[REAL]) and atom(x[IMAG])
end type

function p2round(integer x)
-- rounds x up to a power of two
integer p = 1
    while p<x do
        p += p
    end while
    return p
end function

function log_2(atom x)
-- return log2 of x, or -1 if x is not a power of 2
    if x>0 then
        integer p = -1
        while floor(x)=x do
            x /= 2
            p += 1
        end while
        if x=0.5 then
            return p
        end if
    end if
    return -1
end function

function bitrev(sequence a)
-- bitrev an array of complex numbers
    integer j=1, n = length(a)
    a = deep_copy(a)
    for i=1 to n-1 do
        if i<j then
            {a[i],a[j]} = {a[j],a[i]}
        end if
        integer k = n/2
        while k<j do
            j -= k
            k /= 2
        end while
        j = j+k
    end for
    return a
end function

function cmult(complex arg1, complex arg2)
-- complex multiply
    return {arg1[REAL]*arg2[REAL]-arg1[IMAG]*arg2[IMAG],
            arg1[REAL]*arg2[IMAG]+arg1[IMAG]*arg2[REAL]}
end function

function ip_fft(sequence a)
-- perform an in-place fft on an array of complex numbers
-- that has already been bit reversed
    integer n = length(a)
    integer ip, le, le1
    complex u, w, t

    for l=1 to log_2(n) do
        le = power(2, l)
        le1 = le/2
        u = {1, 0}
        w = {cos(PI/le1), sin(PI/le1)}
        for j=1 to le1 do
            for i=j to n by le do
                ip = i+le1
                t = cmult(a[ip], u)
                a[ip] = sq_sub(a[i],t)
                a[i] = sq_add(a[i],t)
            end for
            u = cmult(u, w)
        end for
    end for
    return a
end function

function fft(sequence a)
    integer n = length(a)
    if log_2(n)=-1 then
        puts(1, "input vector length is not a power of two, padded with 0's\n\n")
        n = p2round(n)
         -- pad with 0's
        for j=length(a)+1 to n do
            a = append(a,{0, 0})
        end for
    end if
    a = ip_fft(bitrev(a))
    -- reverse output from fft to switch +ve and -ve frequencies
    for i=2 to n/2 do
        integer j = n+2-i
        {a[i],a[j]} = {a[j],a[i]}
    end for
    return a
end function

function ifft(sequence a)
    integer n = length(a)
    if log_2(n)=-1 then ?9/0 end if -- (or as above?)
    a = ip_fft(bitrev(a))
    -- modifies results to get inverse fft
    for i=1 to n do
        a[i] = sq_div(a[i],n)
    end for
    return a
end function

constant a = {{1, 0},
              {1, 0},
              {1, 0},
              {1, 0},
              {0, 0},
              {0, 0},
              {0, 0},
              {0, 0}}

printf(1, "Results of %d-point fft:\n\n", length(a))
ppOpt({pp_Nest,1,pp_IntFmt,"%10.6f",pp_FltFmt,"%10.6f"})
pp(fft(a))
printf(1, "\nResults of %d-point inverse fft (rounded to 6 d.p.):\n\n", length(a))
pp(ifft(fft(a)))


INT FUNC Fibonacci(INT n)
  INT curr,prev,tmp

  IF n>=-1 AND n<=1 THEN
    RETURN (n)
  FI

  prev=0
  IF n>0 THEN
    curr=1
    DO
      tmp=prev
      prev=curr
      curr==+tmp
      n==-1
    UNTIL n=1
    OD
  ELSE
    curr=-1
    DO
      tmp=prev
      prev=curr
      curr==+tmp
      n==+1
    UNTIL n=-1
    OD
  FI
RETURN (curr)

PROC Main()
  BYTE n
  INT f

  Put(125) ;clear screen

  FOR n=0 TO 22
  DO
    f=Fibonacci(n)
    Position(2,n+1)
    PrintF("Fib(%I)=%I",n,f)

    IF n>0 THEN
      f=Fibonacci(-n)
      Position(21,n+1)
      PrintF("Fib(%I)=%I",-n,f)
    FI
  OD
RETURN


<?php

class Complex
{
    public $real;
    public $imaginary;

    function __construct($real, $imaginary){
        $this->real = $real;
        $this->imaginary = $imaginary;
    }

    function Add($other, $dst){
        $dst->real = $this->real + $other->real;
        $dst->imaginary = $this->imaginary + $other->imaginary;
        return $dst;
    }

    function Subtract($other, $dst){

        $dst->real = $this->real - $other->real;
        $dst->imaginary = $this->imaginary - $other->imaginary;
        return $dst;
    }

    function Multiply($other, $dst){
        //cache real in case dst === this
        $r = $this->real * $other->real - $this->imaginary * $other->imaginary;
        $dst->imaginary = $this->real * $other->imaginary + $this->imaginary * $other->real;
        $dst->real = $r;
        return $dst;
    }

    function ComplexExponential($dst){
        $er = exp($this->real);
        $dst->real = $er * cos($this->imaginary);
        $dst->imaginary = $er * sin($this->imaginary);
        return $dst;
    }
}


public function fib(n:uint):uint
{
    if (n < 2)
        return n;

    return fib(n - 1) + fib(n - 2);
}


# apt-get install libfftw3-dev

(scl 4)

(de FFTW_FORWARD . -1)
(de FFTW_ESTIMATE . 64)

(de fft (Lst)
   (let
      (Len (length Lst)
         In (native "libfftw3.so" "fftw_malloc" 'N (* Len 16))
         Out (native "libfftw3.so" "fftw_malloc" 'N (* Len 16))
         P (native "libfftw3.so" "fftw_plan_dft_1d" 'N
            Len In Out FFTW_FORWARD FFTW_ESTIMATE ) )
      (struct In NIL (cons 1.0 (apply append Lst)))
      (native "libfftw3.so" "fftw_execute" NIL P)
      (prog1 (struct Out (make (do Len (link (1.0 . 2)))))
         (native "libfftw3.so" "fftw_destroy_plan" NIL P)
         (native "libfftw3.so" "fftw_free" NIL Out)
         (native "libfftw3.so" "fftw_free" NIL In) ) ) )


test: PROCEDURE OPTIONS (MAIN, REORDER); /* Derived from Fortran Rosetta Code */

  /* In-place Cooley-Tukey FFT */
FFT: PROCEDURE (x) RECURSIVE;
   DECLARE  x(*) COMPLEX FLOAT (18);
   DECLARE  t    COMPLEX FLOAT (18);
   DECLARE ( N, Half_N ) FIXED BINARY (31);
   DECLARE ( i, j ) FIXED BINARY (31);
   DECLARE (even(*), odd(*)) CONTROLLED COMPLEX FLOAT (18);
   DECLARE pi FLOAT (18) STATIC INITIAL ( 3.14159265358979323E0);

   N = HBOUND(x);

   if N <= 1 THEN return;

   allocate odd((N+1)/2), even(N/2);

    /* divide */
   do j = 1 to N by 2; odd((j+1)/2) = x(j); end;
   do j = 2 to N by 2; even(j/2)    = x(j); end;

    /* conquer */
   call fft(odd);
   call fft(even);

    /* combine */
   half_N = N/2;
   do i=1 TO half_N;
      t = exp(COMPLEX(0, -2*pi*(i-1)/N))*even(i);
      x(i)        = odd(i) + t;
      x(i+half_N) = odd(i) - t;
   end;

   FREE odd, even;

END fft;

   DECLARE data(8)  COMPLEX FLOAT (18) STATIC INITIAL (
                    1, 1, 1, 1, 0, 0, 0, 0);
   DECLARE ( i ) FIXED BINARY (31);

   call fft(data);

   do i=1 TO 8;
      PUT SKIP LIST ( fixed(data(i), 25, 12) );
   end;

END test;


Function FFT($Arr){
    $Len = $Arr.Count

    If($Len -le 1){Return $Arr}

    $Len_Over_2 = [Math]::Floor(($Len/2))

    $Output  = New-Object System.Numerics.Complex[] $Len

    $EvenArr = @()
    $OddArr  = @()

    For($i = 0; $i -lt $Len; $i++){
        If($i % 2){
            $OddArr+=$Arr[$i]
        }Else{
            $EvenArr+=$Arr[$i]
        }
    }

    $Even = FFT($EvenArr)
    $Odd  = FFT($OddArr)

    For($i = 0; $i -lt $Len_Over_2; $i++){
        $Twiddle = [System.Numerics.Complex]::Exp([System.Numerics.Complex]::ImaginaryOne*[Math]::Pi*($i*-2/$Len))*$Odd[$i]

        $Output[$i]             = $Even[$i] + $Twiddle
        $Output[$i+$Len_Over_2] = $Even[$i] - $Twiddle
    }

    Return $Output
}


with Ada.Text_IO, Ada.Command_Line;

procedure Fib is

   X: Positive := Positive'Value(Ada.Command_Line.Argument(1));

   function Fib(P: Positive) return Positive is
   begin
      if P <= 2 then
         return 1;
      else
         return Fib(P-1) + Fib(P-2);
      end if;
   end Fib;

begin
   Ada.Text_IO.Put("Fibonacci(" & Integer'Image(X) & " ) = ");
   Ada.Text_IO.Put_Line(Integer'Image(Fib(X)));
end Fib;


:- dynamic twiddles/2.
%_______________________________________________________________
% Arithemetic for complex numbers; only the needed rules
add(cx(R1,I1),cx(R2,I2),cx(R,I)) :- R is R1+R2, I is I1+I2.
sub(cx(R1,I1),cx(R2,I2),cx(R,I)) :- R is R1-R2, I is I1-I2.
mul(cx(R1,I1),cx(R2,I2),cx(R,I)) :- R is R1*R2-I1*I2, I is R1*I2+R2*I1.
polar_cx(Mag, Theta, cx(R, I)) :-     % Euler
	R is Mag * cos(Theta), I is Mag * sin(Theta).
%___________________________________________________
% FFT Implementation. Note: K rdiv N is a rational number,
% making the lookup in dynamic database predicate twiddles/2 very
% efficient.  Also, polar_cx/2 gets called only when necessary- in
% this case (N=8), exactly 3 times: (where Tf=1/4, 1/8, or 3/8).
tw(0,cx(1,0)) :- !.                    % Calculate e^(-2*pi*k/N)
tw(Tf, Cx) :- twiddles(Tf, Cx), !.     % dynamic match?
tw(Tf, Cx) :- polar_cx(1.0, -2*pi*Tf, Cx), assert(twiddles(Tf, Cx)).

fftVals(N, Even, Odd, V0, V1) :-       % solves all V0,V1 for N,Even,Odd
	nth0(K,Even,E), nth0(K,Odd,O), Tf is K rdiv N, tw(Tf,Cx),
	mul(Cx,O,M), add(E,M,V0), sub(E,M,V1).

split([],[],[]). % split [[a0,b0],[a1,b1],...] into [a0,a1,...] and [b0,b1,...]
split([[V0,V1]|T], [V0|T0], [V1|T1]) :- !, split(T, T0, T1).

fft([H], [H]).
fft([H|T], List) :-
	length([H|T],N),
	findall(Ve, (nth0(I,[H|T],Ve),I mod 2 =:= 0), EL), !, fft(EL, Even),
	findall(Vo, (nth0(I,T,Vo),I mod 2 =:= 0),OL), !, fft(OL, Odd),
	findall([V0,V1],fftVals(N,Even,Odd,V0,V1),FFTVals),    % calc FFT
	split(FFTVals,L0,L1), append(L0,L1,List).
%___________________________________________________
test :- D=[cx(1,0),cx(1,0),cx(1,0),cx(1,0),cx(0,0),cx(0,0),cx(0,0),cx(0,0)],
	time(fft(D,DRes)), writef('fft=['), P is 10^3, !,
	(member(cx(Ri,Ii), DRes), R is integer(Ri*P)/P, I is integer(Ii*P)/P,
	 write(R), (I>=0, write('+'),fail;write(I)), write('j, '),
	 fail; write(']'), nl).


#include "totvs.ch"
User Function fibb(a,b,n)
return(if(--n>0,fibb(b,a+b,n),a))


from cmath import exp, pi

def fft(x):
    N = len(x)
    if N <= 1: return x
    even = fft(x[0::2])
    odd =  fft(x[1::2])
    T= [exp(-2j*pi*k/N)*odd[k] for k in range(N//2)]
    return [even[k] + T[k] for k in range(N//2)] + \
           [even[k] - T[k] for k in range(N//2)]

print( ' '.join("%5.3f" % abs(f)
                for f in fft([1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0])) )


integer
fibs(integer n)
{
    integer w;

    if (n == 0) {
        w = 0;
    } elif (n == 1) {
        w = 1;
    } else {
        integer a, b, i;

        i = 1;
        a = 0;
        b = 1;
        while (i < n) {
            w = a + b;
            a = b;
            b = w;
            i += 1;
        }
    }

    return w;
}


#lang racket
(require math)
(array-fft (array #[1. 1. 1. 1. 0. 0. 0. 0.]))


sub fft {
    return @_ if @_ == 1;
    my @evn = fft( @_[0, 2 ... *] );
    my @odd = fft( @_[1, 3 ... *] ) Z*
    map &cis, (0, -tau / @_ ... *);
    return flat @evn »+« @odd, @evn »-« @odd;
}

.say for fft <1 1 1 1 0 0 0 0>;


begin
    comment Fibonacci sequence;
    integer procedure fibonacci(n); value n; integer n;
    begin
        integer i, fn, fn1, fn2;
        fn2 := 1;
        fn1 := 0;
        fn  := 0;
        for i := 1 step 1 until n do begin
            fn  := fn1 + fn2;
            fn2 := fn1;
            fn1 := fn
        end;
        fibonacci := fn
    end fibonacci;

    integer i;
    for i := 0 step 1 until 20 do outinteger(1,fibonacci(i))
end


/*REXX program performs a  fast Fourier transform  (FFT)  on a set of  complex numbers. */
numeric digits length( pi() )   -  length(.)     /*limited by the  PI  function result. */
arg data                                         /*ARG verb uppercases the DATA from CL.*/
if data=''  then data= 1 1 1 1 0                 /*Not specified?  Then use the default.*/
size=words(data);       pad= left('', 5)         /*PAD:  for indenting and padding SAYs.*/
  do p=0  until  2**p>=size         ;   end      /*number of args exactly a power of 2? */
  do j=size+1 to 2**p;  data= data 0;   end      /*add zeroes to DATA 'til a power of 2.*/
size= words(data);      ph= p % 2   ;   call hdr         /*╔═══════════════════════════╗*/
                        /* [↓] TRANSLATE allows I & J*/  /*║ Numbers in data can be in ║*/
         do j=0  for size                                /*║ seven formats:  real      ║*/
         _= translate( word(data, j+1), 'J', "I")        /*║                 real,imag ║*/
         parse  var  _    #.1.j  ''  $  1     "," #.2.j  /*║                     ,imag ║*/
         if $=='J'  then parse var #.1.j #2.j "J" #.1.j  /*║                      nnnJ ║*/
                                                         /*║                      nnnj ║*/
           do m=1  for  2;      #.m.j= word(#.m.j 0, 1)  /*║                      nnnI ║*/
           end   /*m*/          /*omitted part?  [↑] */  /*║                      nnni ║*/
                                                         /*╚═══════════════════════════╝*/
         say pad ' FFT   in '     center(j+1, 7)     pad    fmt(#.1.j)     fmt(#.2.j, "i")
         end     /*j*/
say
tran= pi()*2 / 2**p;     !.=0;    hp= 2**p %2;       A= 2**(p-ph);      ptr= A;     dbl= 1
say
         do p-ph;        halfPtr=ptr % 2
                     do i=halfPtr  by ptr  to A-halfPtr;  _= i - halfPtr;   !.i= !._ + dbl
                     end   /*i*/
         ptr= halfPtr;                     dbl= dbl + dbl
         end   /*p-ph*/

         do j=0  to 2**p%4;  cmp.j= cos(j*tran);      _= hp - j;            cmp._= -cmp.j
                                                      _= hp + j;            cmp._= -cmp.j
         end  /*j*/
B= 2**ph
         do i=0      for A;            q= i * B
             do j=0  for B;   h=q+j;   _= !.j*B+!.i;    if _<=h  then iterate
             parse value  #.1._  #.1.h  #.2._  #.2.h    with    #.1.h  #.1._  #.2.h  #.2._
             end   /*j*/                              /* [↑]  swap  two sets of values. */
         end       /*i*/
dbl= 1
         do p                    ;       w= hp % dbl
           do k=0   for dbl      ;      Lb= w * k            ;          Lh= Lb + 2**p % 4
             do j=0 for w        ;       a= j * dbl * 2 + k  ;           b=  a + dbl
             r= #.1.a;  i= #.2.a ;      c1= cmp.Lb * #.1.b   ;          c4= cmp.Lb * #.2.b
                                        c2= cmp.Lh * #.2.b   ;          c3= cmp.Lh * #.1.b
                                     #.1.a= r + c1 - c2      ;       #.2.a= i + c3 + c4
                                     #.1.b= r - c1 + c2      ;       #.2.b= i - c3 - c4
             end     /*j*/
           end       /*k*/
         dbl= dbl + dbl
         end         /*p*/
call hdr
         do z=0  for size
         say pad     " FFT  out "     center(z+1,7)    pad    fmt(#.1.z)    fmt(#.2.z,'j')
         end   /*z*/                             /*[↑] #s are shown with ≈20 dec. digits*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
cos: procedure; parse arg x;  q= r2r(x)**2;      z=1;    _=1;   p=1   /*bare bones COS. */
       do k=2  by 2;  _=-_*q/(k*(k-1));  z=z+_;  if z=p  then return z;   p=z;  end  /*k*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
fmt: procedure; parse arg y,j;          y= y/1   /*prettifies complex numbers for output*/
     if abs(y) < '1e-'digits() %4  then y= 0;    if y=0 & j\==''  then return ''
     dp= digits()%3;  y= format(y, dp%6+1, dp);  if pos(.,y)\==0  then y= strip(y, 'T', 0)
     y=  strip(y, 'T', .);                       return left(y || j, dp)
/*──────────────────────────────────────────────────────────────────────────────────────*/
hdr: _=pad '   data      num' pad "  real─part  " pad pad '         imaginary─part       '
     say _;   say translate(_,  " "copies('═', 256),  " "xrange());                 return
/*──────────────────────────────────────────────────────────────────────────────────────*/
pi:  return 3.1415926535897932384626433832795028841971693993751058209749445923078164062862
r2r: return arg(1)  //  ( pi() * 2 )             /*reduce the radians to a unit circle. */


PROC analytic fibonacci = (LONG INT n)LONG INT:(
  LONG REAL sqrt 5 = long sqrt(5);
  LONG REAL p = (1 + sqrt 5) / 2;
  LONG REAL q = 1/p;
  ROUND( (p**n + q**n) / sqrt 5 )
);

FOR i FROM 1 TO 30 WHILE
  print(whole(analytic fibonacci(i),0));
# WHILE # i /= 30 DO
  print(", ")
OD;
print(new line)


def fft(vec)
  return vec if vec.size <= 1
  evens_odds = vec.partition.with_index{|_,i| i.even?}
  evens, odds = evens_odds.map{|even_odd| fft(even_odd)*2}
  evens.zip(odds).map.with_index do |(even, odd),i|
    even + odd * Math::E ** Complex(0, -2 * Math::PI * i / vec.size)
  end
end

fft([1,1,1,1,0,0,0,0]).each{|c| puts "%9.6f %+9.6fi" % c.rect}


cnt  = 8
sig  = int(log(cnt) /log(2) +0.9999)

pi    = 3.14159265
real1 = 2^sig

real  = real1 -1
real2 = int(real1 /  2)
real4 = int(real1 /  4)
real3 = real4 +real2

dim rel(real1)
dim img(real1)
dim cmp(real3)

for i = 0 to cnt -1
    read rel(i)
    read img(i)
next i

data    1,0, 1,0, 1,0, 1,0, 0,0, 0,0, 0,0, 0,0

sig2 = int(sig / 2)
sig1 = sig -sig2
cnt1 = 2^sig1
cnt2 = 2^sig2

dim v(cnt1 -1)
v(0) = 0
dv   = 1
ptr  = cnt1

for j = 1 to sig1
    hlfPtr = int(ptr / 2)
    pt     = cnt1 - hlfPtr
    for i = hlfPtr to pt step ptr
        v(i) = v(i -hlfPtr) + dv
    next i
    dv = dv + dv
    ptr = hlfPtr
next j

k = 2 *pi /real1

for x = 0 to real4
    cmp(x)         = cos(k *x)
    cmp(real2 - x) = 0 - cmp(x)
    cmp(real2 + x) = 0 - cmp(x)
next x

print "fft: bit reversal"

for i = 0 to cnt1 -1
    ip = i *cnt2
    for j = 0 to cnt2 -1
        h = ip +j
        g = v(j) *cnt2 +v(i)
        if g >h then
                temp   = rel(g)
                rel(g) = rel(h)
                rel(h) = temp
                temp   = img(g)
                img(g) = img(h)
                img(h) = temp
         end if
    next j
next i

t = 1
for stage = 1 to sig
    print "  stage:- "; stage
    d = int(real2 / t)
    for ii = 0 to t -1
        l   = d *ii
        ls  = l +real4
        for i = 0 to d -1
            a      = 2 *i *t +ii
            b      = a +t
            f1     = rel(a)
            f2     = img(a)
            cnt1   = cmp(l)  *rel(b)
            cnt2   = cmp(ls) *img(b)
            cnt3   = cmp(ls) *rel(b)
            cnt4   = cmp(l)  *img(b)
            rel(a) = f1 + cnt1 - cnt2
            img(a) = f2 + cnt3 + cnt4
            rel(b) = f1 - cnt1 + cnt2
            img(b) = f2 - cnt3 - cnt4
        next i
    next ii
    t = t +t
next stage

print "  Num   real   imag"
for i = 0 to real
    if abs(rel(i)) <10^-5 then rel(i) = 0
    if abs(img(i)) <10^-5 then img(i) = 0
    print "   "; i;"   ";using("##.#",rel(i));"    ";img(i)
next i
end


begin
    % return the nth Fibonacci number %
    integer procedure Fibonacci( integer value n ) ;
        begin
            integer fn, fn1, fn2;
            fn2 := 1;
            fn1 := 0;
            fn  := 0;
            for i := 1 until n do begin
                fn  := fn1 + fn2;
                fn2 := fn1;
                fn1 := fn
            end ;
            fn
        end Fibonacci ;

    for i := 0 until 10 do writeon( i_w := 3, s_w := 0, Fibonacci( i ) )

end.


extern crate num;
use num::complex::Complex;
use std::f64::consts::PI;

const I: Complex<f64> = Complex { re: 0.0, im: 1.0 };

pub fn fft(input: &[Complex<f64>]) -> Vec<Complex<f64>> {
    fn fft_inner(
        buf_a: &mut [Complex<f64>],
        buf_b: &mut [Complex<f64>],
        n: usize,    // total length of the input array
        step: usize, // precalculated values for t
    ) {
        if step >= n {
            return;
        }

        fft_inner(buf_b, buf_a, n, step * 2);
        fft_inner(&mut buf_b[step..], &mut buf_a[step..], n, step * 2);
        // create a slice for each half of buf_a:
        let (left, right) = buf_a.split_at_mut(n / 2);

        for i in (0..n).step_by(step * 2) {
            let t = (-I * PI * (i as f64) / (n as f64)).exp() * buf_b[i + step];
            left[i / 2] = buf_b[i] + t;
            right[i / 2] = buf_b[i] - t;
        }
    }

    // round n (length) up to a power of 2:
    let n_orig = input.len();
    let n = n_orig.next_power_of_two();
    // copy the input into a buffer:
    let mut buf_a = input.to_vec();
    // right pad with zeros to a power of two:
    buf_a.append(&mut vec![Complex { re: 0.0, im: 0.0 }; n - n_orig]);
    // alternate between buf_a and buf_b to avoid allocating a new vector each time:
    let mut buf_b = buf_a.clone();
    fft_inner(&mut buf_a, &mut buf_b, n, 1);
    buf_a
}

fn show(label: &str, buf: &[Complex<f64>]) {
    println!("{}", label);
    let string = buf
        .into_iter()
        .map(|x| format!("{:.4}{:+.4}i", x.re, x.im))
        .collect::<Vec<_>>()
        .join(", ");
    println!("{}", string);
}

fn main() {
    let input: Vec<_> = [1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0]
        .into_iter()
        .map(|x| Complex::from(x))
        .collect();
    show("input:", &input);
    let output = fft(&input);
    show("output:", &output);
}


import scala.math.{ Pi, cos, sin, cosh, sinh, abs }

case class Complex(re: Double, im: Double) {
    def +(x: Complex): Complex = Complex(re + x.re, im + x.im)
    def -(x: Complex): Complex = Complex(re - x.re, im - x.im)
    def *(x: Double):  Complex = Complex(re * x, im * x)
    def *(x: Complex): Complex = Complex(re * x.re - im * x.im, re * x.im + im * x.re)
    def /(x: Double):  Complex = Complex(re / x, im / x)

    override def toString(): String = {
        val a = "%1.3f" format re
        val b = "%1.3f" format abs(im)
        (a,b) match {
            case (_, "0.000") => a
            case ("0.000", _) => b + "i"
            case (_, _) if im > 0 => a + " + " + b + "i"
            case (_, _) => a + " - " + b + "i"
        }
    }
}

def exp(c: Complex) : Complex = {
    val r = (cosh(c.re) + sinh(c.re))
    Complex(cos(c.im), sin(c.im)) * r
}


INTEGER FUNCTION FIBONACCI( X ); INTEGER X;
BEGIN
    INTEGER M, N, A, I;
    M := 0;
    N := 1;
    FOR I := 2 STEP 1 UNTIL X DO
    BEGIN
        A := N;
        N := M + N;
        M := A;
    END;
    FIBONACCI := N;
END;


; Compute and return the FFT of the given input vector using the Cooley-Tukey Radix-2
; Decimation-in-Time (DIT) algorithm.  The input is assumed to be a vector of complex
; numbers that is a power of two in length greater than zero.

(define fft-r2dit
  (lambda (in-vec)
    ; The constant ( -2 * pi * i ).
    (define -2*pi*i (* -2.0i (atan 0 -1)))
    ; The Cooley-Tukey Radix-2 Decimation-in-Time (DIT) procedure.
    (define fft-r2dit-aux
      (lambda (vec start leng stride)
        (if (= leng 1)
          (vector (vector-ref vec start))
          (let* ((leng/2 (truncate (/ leng 2)))
                 (evns (fft-r2dit-aux vec 0 leng/2 (* stride 2)))
                 (odds (fft-r2dit-aux vec stride leng/2 (* stride 2)))
                 (dft (make-vector leng)))
            (do ((inx 0 (1+ inx)))
                ((>= inx leng/2) dft)
              (let ((e (vector-ref evns inx))
                    (o (* (vector-ref odds inx) (exp (* inx (/ -2*pi*i leng))))))
                (vector-set! dft inx (+ e o))
                (vector-set! dft (+ inx leng/2) (- e o))))))))
    ; Call the Cooley-Tukey Radix-2 Decimation-in-Time (DIT) procedure w/ appropriate
    ; arguments as derived from the argument to the fft-r2dit procedure.
    (fft-r2dit-aux in-vec 0 (vector-length in-vec) 1)))

; Test using a simple pulse.

(let* ((inp (vector 1.0 1.0 1.0 1.0 0.0 0.0 0.0 0.0))
       (dft (fft-r2dit inp)))
  (printf "In:  ~a~%" inp)
  (printf "DFT: ~a~%" dft))


def fib(n as Int) as Int
   if n < 2
      return 1
   end
   return fib(n-1) + fib(n-2)
end


import <Utilities/Complex.sl>;
import <Utilities/Math.sl>;
import <Utilities/Sequence.sl>;

fft(x(1)) :=
    let
        n := size(x);

        top := fft(x[range(1,n-1,2)]);
        bottom := fft(x[range(2,n,2)]);

        d[i] := makeComplex(cos(2.0*pi*i/n), -sin(2.0*pi*i/n)) foreach i within 0...(n / 2 - 1);

        z := complexMultiply(d, bottom);
    in
        x when n <= 1
    else
        complexAdd(top,z) ++ complexSubtract(top,z);


#include <hbasic.h>

#define TERM1    1.61803398874989
#define TERM2    -0.61803398874989

#context get Fibonacci number with analitic mode
  GetArgs(n)
  get Inv of (M_SQRT5), Mul by( Pow (TERM 1, n), Minus( Pow(TERM 2, n) )  );
  then Return\\

#proto fibonacci_recursive(__X__)
#synon _fibonacci_recursive    getFibonaccinumberwithrecursivemodeof

#proto fibonacci_iterative(__X__)
#synon _fibonacci_iterative    getFibonaccinumberwithiterativemodeof

Begin
  Option Stack 1024

  get Arg Number(2, n), and Take( n );
  then, get Fibonacci number with analitic mode, and Print It with a Newl.
  secondly, get Fibonacci number with recursive mode of(n), and Print It with a Newl.
  finally, get Fibonacci number with iterative mode of (n), and Print It with a Newl.
End

Subrutines

fibonacci_recursive(n)
   Iif ( var(n) Is Le? (2), 1 , \
         get Fibonacci number with recursive mode of( var(n) Minus (1));\
         get Fibonacci number with recursive mode of( var(n) Minus (2)); and Add It )
Return

fibonacci_iterative(n)
  A=0
  B=1
  For Up( I:=2, n, 1 )
    C=B
    Let ( B: = var(A) Plus (B) )
    A=C
  Next
Return(B)


func fft(arr) {
    arr.len == 1 && return arr

    var evn = fft([arr[^arr -> grep { .is_even }]])
    var odd = fft([arr[^arr -> grep { .is_odd  }]])
    var twd = (Num.tau.i / arr.len)

    ^odd -> map {|n| odd[n] *= ::exp(twd * n)}
    (evn »+« odd) + (evn »-« odd)
}

var cycles = 3
var sequence = 0..15
var wave = sequence.map {|n| ::sin(n * Num.tau / sequence.len * cycles) }
say "wave:#{wave.map{|w| '%6.3f' % w }.join(' ')}"
say "fft: #{fft(wave).map { '%6.3f' % .abs }.join(' ')}"


import Foundation
import Numerics

typealias Complex = Numerics.Complex<Double>

extension Complex {
  var exp: Complex {
    Complex(cos(imaginary), sin(imaginary)) * Complex(cosh(real), sinh(real))
  }

  var pretty: String {
    let fmt = { String(format: "%1.3f", $0) }
    let re = fmt(real)
    let im = fmt(abs(imaginary))

    if im == "0.000" {
      return re
    } else if re == "0.000" {
      return im
    } else if imaginary > 0 {
      return re + " + " + im + "i"
    } else {
      return re + " - " + im +  "i"
    }
  }
}

func fft(_ array: [Complex]) -> [Complex] { _fft(array, direction: Complex(0.0, 2.0), scalar: 1) }
func rfft(_ array: [Complex]) -> [Complex] { _fft(array, direction: Complex(0.0, -2.0), scalar: 2) }

private func _fft(_ arr: [Complex], direction: Complex, scalar: Double) -> [Complex] {
  guard arr.count > 1 else {
    return arr
  }

  let n = arr.count
  let cScalar = Complex(scalar, 0)

  precondition(n % 2 == 0, "The Cooley-Tukey FFT algorithm only works when the length of the input is even.")

  var (evens, odds) = arr.lazy.enumerated().reduce(into: ([Complex](), [Complex]()), {res, cur in
    if cur.offset & 1 == 0 {
      res.0.append(cur.element)
    } else {
      res.1.append(cur.element)
    }
  })

  evens = _fft(evens, direction: direction, scalar: scalar)
  odds = _fft(odds, direction: direction, scalar: scalar)

  let (left, right) = (0 ..< n / 2).map({i -> (Complex, Complex) in
    let offset = (direction * Complex((.pi * Double(i) / Double(n)), 0)).exp * odds[i] / cScalar
    let base = evens[i] / cScalar

    return (base + offset, base - offset)
  }).reduce(into: ([Complex](), [Complex]()), {res, cur in
    res.0.append(cur.0)
    res.1.append(cur.1)
  })

  return left + right
}

let dat = [Complex(1.0, 0.0), Complex(1.0, 0.0), Complex(1.0, 0.0), Complex(1.0, 0.0),
           Complex(0.0, 0.0), Complex(0.0, 2.0), Complex(0.0, 0.0), Complex(0.0, 0.0)]

print(fft(dat).map({ $0.pretty }))
print(rfft(f).map({ $0.pretty }))


package math_pkg;
  // Inspired by the post
  // https://community.cadence.com/cadence_blogs_8/b/fv/posts/create-a-sine-wave-generator-using-systemverilog
  // import functions directly from C library
  //import dpi task      C Name = SV function name
  import "DPI" pure function real cos (input real rTheta);
  import "DPI" pure function real sin(input real y);
  import "DPI" pure function real atan2(input real y, input real x);
endpackage : math_pkg

// Encapsulates the functions in a parameterized class
// The FFT is implemented using floating point arithmetic (systemverilog real)
// Complex values are represented as a real vector [1:0], the index 0 is the real part
// and the index 1 is the imaginary part.
class fft_fp #(
  parameter LOG2_NS = 7,
  parameter NS = 1<<LOG2_NS
);

  static function void bit_reverse_order(input real buffer_in[0:NS-1][1:0], output real buffer[0:NS-1][1:0]);
  begin
    for(reg [LOG2_NS:0] j = 0; j < NS; j = j + 1) begin
      reg [LOG2_NS-1:0] ij;
      ij = {<<{j[LOG2_NS-1:0]}}; // Right to left streaming
      buffer[j][0] = buffer_in[ij][0];
      buffer[j][1] = buffer_in[ij][1];
    end
  end
  endfunction
  // SystemVerilog FFT implementation translated from Java
  static function void transform(input real buffer_in[0:NS-1][1:0], output real buffer[0:NS-1][1:0]);
  begin
    static real pi = math_pkg::atan2(0.0, -1.0);
    bit_reverse_order(buffer_in, buffer);
    for(int N = 2; N <= NS; N = N << 1) begin
      for(int i = 0; i < NS; i = i + N) begin
        for(int k =0; k < N/2; k = k + 1) begin
          int evenIndex;
          int oddIndex;
          real theta;
          real wr, wi;
          real zr, zi;
          evenIndex = i + k;
          oddIndex  = i + k + (N/2);
          theta     = (-2.0*pi*k/real'(N));
          // Call to the DPI C functions
          // (it could be memorized to save some calls but I dont think it worthes)
          // w = exp(-2j*pi*k/N);
          wr = math_pkg::cos(theta);
          wi = math_pkg::sin(theta);
          // x = w * buffer[oddIndex]
          zr = buffer[oddIndex][0] * wr - buffer[oddIndex][1] * wi;
          zi = buffer[oddIndex][0] * wi + buffer[oddIndex][1] * wr;
          // update oddIndex before evenIndex
          buffer[ oddIndex][0] = buffer[evenIndex][0] - zr;
          buffer[ oddIndex][1] = buffer[evenIndex][1] - zi;
          // because evenIndex is in the rhs
          buffer[evenIndex][0] = buffer[evenIndex][0] + zr;
          buffer[evenIndex][1] = buffer[evenIndex][1] + zi;
        end
      end
    end
  end
  endfunction
  // Implements the inverse FFT using the following identity
  // ifft(x) = conj(fft(conj(x))/NS;
  static function void invert(input real buffer_in[0:NS-1][1:0], output real buffer[0:NS-1][1:0]);
    real tmp[0:NS-1][1:0];
  begin
    // Conjugates the input
    for(int i = 0; i < NS; i = i + 1) begin
      tmp[i][0] = buffer_in[i][0];
      tmp[i][1] = -buffer_in[i][1];
    end
    transform(tmp, buffer);
    // Conjugate and scale the output
    for(int i = 0; i < NS; i = i + 1) begin
      buffer[i][0] = buffer[i][0]/NS;
      buffer[i][1] = -buffer[i][1]/NS;
    end
  end
  endfunction

endclass


/*
 author: snugsfbay
 date: March 3, 2016
 description: Create a list of x numbers in the Fibonacci sequence.
     - user may specify the length of the list
     - enforces a minimum of 2 numbers in the sequence because any fewer is not a sequence
     - enforces a maximum of 47 because further values are too large for integer data type
     - Fibonacci sequence always starts with 0 and 1 by definition
*/
public class FibNumbers{

final static Integer MIN = 2; //minimum length of sequence
final static Integer MAX = 47; //maximum length of sequence

/*
  description: method to create a list of numbers in the Fibonacci sequence
  param: user specified integer representing length of sequence should be 2-47, inclusive.
      - Sequence starts with 0 and 1 by definition so the minimum length could be as low as 2.
      - For 48th number in sequence or greater, code would require a Long data type rather than an Integer.
  return: list of integers in sequence.
*/
public static List<Integer> makeSeq(Integer len){

  List<Integer> fib = new List<Integer>{0,1}; // initialize list with first two values
  Integer i;

  if(len<MIN || len==null || len>MAX) {
      if (len>MAX){
          len=MAX; //set length to maximum if user entered too high a value
      }else{
          len=MIN; //set length to minimum if user entered too low a value or none
      }
  } //This could be refactored using teneray operator, but we want code coverage to be reflected for each condition

  //start with initial list size to find previous two values in the sequence, continue incrementing until list reaches user defined length
  for(i=fib.size(); i<len; i++){
    fib.add(fib[i-1]+fib[i-2]); //create new number based on previous numbers and add that to the list
  }

  return fib;
  }

}


package require math::constants
package require math::fourier

math::constants::constants pi
# Helper functions
proc wave {samples cycles} {
    global pi
    set wave {}
    set factor [expr {2*$pi * $cycles / $samples}]
    for {set i 0} {$i < $samples} {incr i} {
	lappend wave [expr {sin($factor * $i)}]
    }
    return $wave
}
proc printwave {waveName {format "%7.3f"}} {
    upvar 1 $waveName wave
    set out [format "%-6s" ${waveName}:]
    foreach value $wave {
	append out [format $format $value]
    }
    puts $out
}
proc waveMagnitude {wave} {
    set out {}
    foreach value $wave {
	lassign $value re im
	lappend out [expr {hypot($re, $im)}]
    }
    return $out
}

set wave [wave 16 3]
printwave wave
# Uses FFT if input length is power of 2, and a less efficient algorithm otherwise
set fft [math::fourier::dft $wave]
# Convert to magnitudes for printing
set fft2 [waveMagnitude $fft]
printwave fft2


F perim_equal(p1, =p2)
   I p1.len != p2.len | Set(p1) != Set(p2)
      R 0B
   I any((0 .< p1.len).map(n -> @p2 == (@p1[n ..] [+] @p1[0 .< n])))
      R 1B
   p2 = reversed(p2)
   R any((0 .< p1.len).map(n -> @p2 == (@p1[n ..] [+] @p1[0 .< n])))

F edge_to_periphery(e)
   V edges = sorted(e)
   [Int] p
   I !edges.empty
      p = [edges[0][0], edges[0][1]]
      edges.pop(0)
   V last = I !p.empty {p.last} E -1
   L !edges.empty
      L(ij) edges
         V (i, j) = ij
         I i == last
            p.append(j)
            last = j
            edges.pop(L.index)
            L.break
         E I j == last
            p.append(i)
            last = i
            edges.pop(L.index)
            L.break
      L.was_no_break
         R ‘>>>Error! Invalid edge format<<<’
   R String(p[0 .< (len)-1])

print(‘Perimeter format equality checks:’)
L(eq_check) [(‘Q’, [8, 1, 3],
              ‘R’, [1, 3, 8]),
             (‘U’, [18, 8, 14, 10, 12, 17, 19],
              ‘V’, [8, 14, 10, 12, 17, 19, 18])]
   V (n1, p1, n2, p2) = eq_check
   V eq = I perim_equal(p1, p2) {‘==’} E ‘!=’
   print(‘  ’n1‘ ’eq‘ ’n2)

print("\nEdge to perimeter format translations:")
V edge_d = [‘E’ = [(1, 11), (7, 11), (1, 7)],
            ‘F’ = [(11, 23), (1, 17), (17, 23), (1, 11)],
            ‘G’ = [(8, 14), (17, 19), (10, 12), (10, 14), (12, 17), (8, 18), (18, 19)],
            ‘H’ = [(1, 3), (9, 11), (3, 11), (1, 11)]]
L(name, edges) edge_d
   print(‘  ’name‘: ’edges"\n     -> "edge_to_periphery(edges))


#import nat
#import flo

f = <1+0j,1+0j,1+0j,1+0j,0+0j,0+0j,0+0j,0+0j>    # complex sequence of 4 1's and 4 0's

g = c..mul^*D(sqrt+ float+ length,..u_fw_dft) f  # its fft

#cast %jLW

t = (f,g)


import math.complex
import math
fn ditfft2(x []f64, mut y []Complex, n int, s int) {
    if n == 1 {
        y[0] = complex(x[0], 0)
        return
    }
    ditfft2(x, mut y, n/2, 2*s)
    ditfft2(x[s..], mut y[n/2..], n/2, 2*s)
    for k := 0; k < n/2; k++ {
        tf := cmplx.Rect(1, -2*math.pi*f64(k)/f64(n)) * y[k+n/2]
        y[k], y[k+n/2] = y[k]+tf, y[k]-tf
    }
}

fn main() {
    x := [f64(1), 1, 1, 1, 0, 0, 0, 0]
    mut y := []Complex{len: x.len}
    ditfft2(x, mut y, x.len, 1)
    for c in y {
        println("${c:8.4f}")
    }
}


import "/complex" for Complex
import "/fmt" for Fmt

var ditfft2 // recursive
ditfft2 = Fn.new {|x, y, n, s|
    if (n == 1) {
        y[0] = Complex.new(x[0], 0)
        return
    }
    var hn = (n/2).floor
    ditfft2.call(x, y, hn, 2*s)
    var z = y[hn..-1]
    ditfft2.call(x[s..-1], z, hn, 2*s)
    for (i in hn...y.count) y[i] = z[i-hn]
    for (k in 0...hn) {
        var tf = Complex.fromPolar(1, -2 * Num.pi * k / n) * y[k + hn]
        var t = y[k]
        y[k] = y[k] + tf
        y[k + hn] = t - tf
    }
}

var x = [1, 1, 1, 1, 0, 0, 0, 0]
var y = List.filled(x.count, null)
for (i in 0...y.count) y[i] = Complex.zero
ditfft2.call(x, y, x.count, 1)
for (c in y) Fmt.print("$6.4z", c)


package main

import (
    "fmt"
    "sort"
)

// Check a slice contains a value.
func contains(s []int, f int) bool {
    for _, e := range s {
        if e == f {
            return true
        }
    }
    return false
}

// Assumes s1, s2 are of same length.
func sliceEqual(s1, s2 []int) bool {
    for i := 0; i < len(s1); i++ {
        if s1[i] != s2[i] {
            return false
        }
    }
    return true
}

// Reverses slice in place.
func reverse(s []int) {
    for i, j := 0, len(s)-1; i < j; i, j = i+1, j-1 {
        s[i], s[j] = s[j], s[i]
    }
}

// Check two perimeters are equal.
func perimEqual(p1, p2 []int) bool {
    le := len(p1)
    if le != len(p2) {
        return false
    }
    for _, p := range p1 {
        if !contains(p2, p) {
            return false
        }
    }
    // use copy to avoid mutating 'p1'
    c := make([]int, le)
    copy(c, p1)
    for r := 0; r < 2; r++ {
        for i := 0; i < le; i++ {
            if sliceEqual(c, p2) {
                return true
            }
            // do circular shift to right
            t := c[le-1]
            copy(c[1:], c[0:le-1])
            c[0] = t
        }
        // now process in opposite direction
        reverse(c)
    }
    return false
}

type edge [2]int

// Translates a face to perimeter format.
func faceToPerim(face []edge) []int {
    // use copy to avoid mutating 'face'
    le := len(face)
    if le == 0 {
        return nil
    }
    edges := make([]edge, le)
    for i := 0; i < le; i++ {
        // check edge pairs are in correct order
        if face[i][1] <= face[i][0] {
            return nil
        }
        edges[i] = face[i]
    }
    // sort edges in ascending order
    sort.Slice(edges, func(i, j int) bool {
        if edges[i][0] != edges[j][0] {
            return edges[i][0] < edges[j][0]
        }
        return edges[i][1] < edges[j][1]
    })
    var perim []int
    first, last := edges[0][0], edges[0][1]
    perim = append(perim, first, last)
    // remove first edge
    copy(edges, edges[1:])
    edges = edges[0 : le-1]
    le--
outer:
    for le > 0 {
        for i, e := range edges {
            found := false
            if e[0] == last {
                perim = append(perim, e[1])
                last, found = e[1], true
            } else if e[1] == last {
                perim = append(perim, e[0])
                last, found = e[0], true
            }
            if found {
                // remove i'th edge
                copy(edges[i:], edges[i+1:])
                edges = edges[0 : le-1]
                le--
                if last == first {
                    if le == 0 {
                        break outer
                    } else {
                        return nil
                    }
                }
                continue outer
            }
        }
    }
    return perim[0 : len(perim)-1]
}

func main() {
    fmt.Println("Perimeter format equality checks:")
    areEqual := perimEqual([]int{8, 1, 3}, []int{1, 3, 8})
    fmt.Printf("  Q == R is %t\n", areEqual)
    areEqual = perimEqual([]int{18, 8, 14, 10, 12, 17, 19}, []int{8, 14, 10, 12, 17, 19, 18})
    fmt.Printf("  U == V is %t\n", areEqual)
    e := []edge{{7, 11}, {1, 11}, {1, 7}}
    f := []edge{{11, 23}, {1, 17}, {17, 23}, {1, 11}}
    g := []edge{{8, 14}, {17, 19}, {10, 12}, {10, 14}, {12, 17}, {8, 18}, {18, 19}}
    h := []edge{{1, 3}, {9, 11}, {3, 11}, {1, 11}}
    fmt.Println("\nEdge to perimeter format translations:")
    for i, face := range [][]edge{e, f, g, h} {
        perim := faceToPerim(face)
        if perim == nil {
            fmt.Printf("  %c => Invalid edge format\n", i + 'E')
        } else {
            fmt.Printf("  %c => %v\n", i + 'E', perim)
        }
    }
}


set fibs to {}
set x to (text returned of (display dialog "What fibbonaci number do you want?" default answer "3"))
set x to x as integer
repeat with y from 1 to x
	if (y = 1 or y = 2) then
		copy 1 to the end of fibs
	else
		copy ((item (y - 1) of fibs) + (item (y - 2) of fibs)) to the end of fibs
	end if
end repeat
return item x of fibs


var [const] GSL=Import("zklGSL");	// libGSL (GNU Scientific Library)
v:=GSL.ZVector(8).set(1,1,1,1);
GSL.FFT(v).toList().concat("\n").println();  // in place


import Data.List (find, delete, (\\))
import Control.Applicative ((<|>))

------------------------------------------------------------

newtype Perimeter a = Perimeter [a]
  deriving Show

instance Eq a => Eq (Perimeter a) where
  Perimeter p1 == Perimeter p2 =
    null (p1 \\ p2)
    && ((p1 `elem` zipWith const (iterate rotate p2) p1)
        || Perimeter p1 == Perimeter (reverse p2))

rotate lst = zipWith const (tail (cycle lst)) lst

toEdges :: Ord a => Perimeter a -> Maybe (Edges a)
toEdges (Perimeter ps)
  | allDifferent ps = Just . Edges $ zipWith ord ps (tail (cycle ps))
  | otherwise = Nothing
  where
    ord a b = if a < b then (a, b) else (b, a)

allDifferent [] = True
allDifferent (x:xs) = all (x /=) xs && allDifferent xs

------------------------------------------------------------

newtype Edges a = Edges [(a, a)]
  deriving Show

instance Eq a => Eq (Edges a) where
  e1 == e2 = toPerimeter e1 == toPerimeter e2

toPerimeter :: Eq a => Edges a -> Maybe (Perimeter a)
toPerimeter (Edges ((a, b):es)) = Perimeter . (a :) <$> go b es
  where
    go x rs
      | x == a = return []
      | otherwise = do
          p <- find ((x ==) . fst) rs <|> find ((x ==) . snd) rs
          let next = if fst p == x then snd p else fst p
          (x :) <$> go next (delete p rs)


   NB. construct a list of all rotations of one of the faces
   NB. including all rotations of the reversed list.
   NB. Find out if the other face is a member of this list.

   NB. ,&:rotations -> append, but first enlist the rotations.

   rotations=. |."0 1~ [email protected]#
   reverse=: |.
   same_perimeter=: e. (,&:rotations reverse)

   (3, 1, 8)same_perimeter(8, 1, 3)
1

   (18, 8, 14, 10, 12, 17, 19)same_perimeter(8, 14, 10, 12, 17, 19, 18)
1


( fibonacci , 1; 1 )

[ 98 , // 100 numbers of fibonacci

	( fibonacci[ @fibonacci? ] ,

		@fibonacci[ @fibonacci - 1 ] + @fibonacci[ @fibonacci - 2 ]

	)

	"Index: | @fibonacci? | => | @fibonacci[ @fibonacci? - 1 ] |"
]


iseq(f, g) = any(n -> f == circshift(g, n), 1:length(g))

function toface(evec)
    try
        ret, edges = collect(evec[1]), copy(evec[2:end])
        while !isempty(edges)
            i = findfirst(x -> ret[end] == x[1] || ret[end] == x[2], edges)
            push!(ret, ret[end] == edges[i][1] ? edges[i][2] : edges[i][1])
            deleteat!(edges, i)
        end
        return ret[1:end-1]
    catch
        println("Invalid edges vector: $evec")
        exit(1)
    end
end

const faces1 = [
    [[8, 1, 3], [1, 3, 8]],
    [[18, 8, 14, 10, 12, 17, 19], [8, 14, 10, 12, 17, 19, 18]]
]

const faces2 = [
    [(1, 11), (7, 11), (1, 7)], [(11, 23), (1, 17), (17, 23), (1, 11)],
    [(8, 14), (17, 19), (10, 12), (10, 14), (12, 17), (8, 18), (18, 19)],
    [(1, 3), (9, 11), (3, 11), (1, 11)]
]

for faces in faces1
    println("Faces are ", iseq(faces[1], faces[2]) ? "" : "not ", "equivalent.")
end

for face in faces2
    println(toface(face))
end


import algorithm, strutils

type
  Perimeter = seq[int]
  Face = tuple[name: char; perimeter: Perimeter]
  Edge = tuple[first, last: int]

const None = -1   # No point.

#---------------------------------------------------------------------------------------------------

func isSame(p1, p2: Perimeter): bool =
  ## Return "true" if "p1" and "p2" represent the same face.

  if p1.len != p2.len: return false

  for p in p1:
    if p notin p2: return false

  var start = p2.find(p1[0])
  if p1 == p2[start..^1] & p2[0..<start]:
    return true

  let p3 = reversed(p2)
  start = p3.find(p1[0])
  if p1 == p3[start..^1] & p3[0..<start]:
    return true

#---------------------------------------------------------------------------------------------------

func `$`(perimeter: Perimeter): string =
  ## Convert a perimeter to a string.
  '(' & perimeter.join(", ") & ')'

func `$`(face: Face): string =
  ## Convert a perimeter formatted face to a string.
  face.name & $face.perimeter

#---------------------------------------------------------------------------------------------------

func toPerimeter(edges: seq[Edge]): Perimeter =
  ## Convert a list of edges to perimeter representation.
  ## Return an empty perimeter if the list of edges doesn’t represent a face.

  var edges = edges
  let firstEdge = edges.pop()       # First edge taken in account.
  var nextPoint = firstEdge.first   # Next point to search in remaining edges.
  result.add(nextpoint)

  while edges.len > 0:
    # Search an edge.
    var idx = None
    for i, e in edges:
      if e.first == nextPoint or e.last == nextPoint:
        idx = i
        nextPoint = if nextpoint == e.first: e.last else: e.first
        break
    if idx == None:
      return @[]      # No edge found containing "newPoint".

    # Add next point to perimeter and remove the edge.
    result.add(nextPoint)
    edges.del(idx)

  # Check that last added point is the expected one.
  if nextPoint != firstEdge.last:
    return @[]

#———————————————————————————————————————————————————————————————————————————————————————————————————

when isMainModule:

  # List of pairs of perimeter formatted faces to compare.
  const FP = [(('P', @[8, 1, 3]), ('R', @[1, 3, 8])),
              (('U', @[18, 8, 14, 10, 12, 17, 19]), ('V', @[8, 14, 10, 12, 17, 19, 18]))]

  echo "Perimeter comparison:"
  for (p1, p2) in FP:
    echo p1, if isSame(p1[1], p2[1]): " is same as " else: "is not same as", p2

  # List of edge formatted faces.
  const FE = {'E': @[(1, 11), (7, 11), (1, 7)],
              'F': @[(11, 23), (1, 17), (17, 23), (1, 11)],
              'G': @[(8, 14), (17, 19), (10, 12), (10, 14), (12, 17), (8, 18), (18, 19)],
              'H': @[(1, 3), (9, 11), (3, 11), (1, 11)]}

  echo ""
  echo "Conversion from edge to perimeter format:"
  for (faceName, edges) in FE:
    let perimeter = edges.toPerimeter()
    echo faceName, ": ", if perimeter.len == 0: "Invalid edge list" else: $perimeter


fibonacci:
        push  {r1-r3}
        mov   r1,  #0
        mov   r2,  #1

fibloop:
        mov   r3,  r2
        add   r2,  r1,  r2
        mov   r1,  r3
        sub   r0,  r0,  #1
        cmp   r0,  #1
        bne   fibloop

        mov   r0,  r2
        pop   {r1-r3}
        mov   pc,  lr


F factor(n)
   V factors = Set[Int]()
   L(x) 1..Int(sqrt(n))
      I n % x == 0
         factors.add(x)
         factors.add(n I/ x)
   R sorted(Array(factors))

L(i) (45, 53, 64)
   print(i‘: factors: ’String(factor(i)))


*        Factors of an integer -   07/10/2015
FACTOR   CSECT
         USING  FACTOR,R15         set base register
         LA     R7,PG              [email protected]
         LA     R6,1               i
         L      R3,N               loop count
LOOP     L      R5,N               n
         LA     R4,0
         DR     R4,R6              n/i
         LTR    R4,R4              if mod(n,i)=0
         BNZ    NEXT
         XDECO  R6,PG+120          edit i
         MVC    0(6,R7),PG+126     output i
         LA     R7,6(R7)           pgi=pgi+6
NEXT     LA     R6,1(R6)           i=i+1
         BCT    R3,LOOP            loop
         XPRNT  PG,120             print buffer
         XR     R15,R15            set return code
         BR     R14                return to caller
N        DC     F'12345'           <== input value
PG       DC     CL132' '           buffer
         YREGS
         END    FACTOR


with javascript_semantics
function perequiv(sequence a, b)
-- Works by aligning and rotating in one step, so theoretically much faster on massive sets.
-- (ahem, faster than multiple rotates, index-only loops would obviously be even faster...)
    bool res = (length(a)==length(b))
    if res and length(a)>0 then
        integer k = find(a[1],b)
        if k=0 then
            res = false
        else
            -- align with a (ie make b[1]==a[1], by
            -- rotating b k places in one operation)
            b = b[k..$]&b[1..k-1]
            if a!=b then
                -- eg {8,3,4,5} <=> {8,5,4,3}, ie
                -- rotate *and* keep in alignment.
                b[2..$] = reverse(b[2..$])
                res = (a==b)
            end if
        end if
    end if
--  return res
    return {"false","true"}[res+1]
end function

function edge2peri(sequence edges)
    sequence was = edges, res = {}
    string error = ""
    integer lnk = 0
    if length(edges)<2 then
        error = "too short"
    else
--      edges = sort(deep_copy(edges)) -- (see note below)
        res = deep_copy(edges[1])
        edges = edges[2..$]
        lnk = res[2]
        while length(edges) and error="" do
            bool found = false
            for i=1 to length(edges) do
                integer k = find(lnk,edges[i])
                if k then
                    lnk = edges[i][3-k]
                    edges[i..i] = {}
                    if edges={} then
                        if lnk!=res[1] then error = "oh dear" end if
                    else
                        if find(lnk,res) then error = "oops" end if
                        res &= lnk
                    end if
                    found = true
                    exit
                end if
            end for
            if not found then error = "bad link" exit end if
        end while
    end if
    if length(error) then res = {error,res,lnk,edges,was} end if
    return res
end function

constant ptests = {{{8, 1, 3}, {1, 3, 8}},
                   {{18, 8, 14, 10, 12, 17, 19}, {8, 14, 10, 12, 17, 19, 18}},
                    -- (check our results below against Go etc)
                   {{1,11,7},{1,7,11}},
                   {{11,23,17,1},{1,11,23,17}}}
for i=1 to length(ptests) do
    sequence {p,q} = ptests[i]
    printf(1,"%v equivalent to %v: %s\n",{p,q,perequiv(p,q)})
end for

constant etests = {{{1, 11}, {7, 11}, {1, 7}},
                   {{11, 23}, {1, 17}, {17, 23}, {1, 11}},
                   {{8, 14}, {17, 19}, {10, 12}, {10, 14}, {12, 17}, {8, 18}, {18, 19}},
                   {{1, 3}, {9, 11}, {3, 11}, {1, 11}}}
for i=1 to length(etests) do
    printf(1,"%v\n",{edge2peri(etests[i])})
end for


IT'S SHOWTIME

HEY CHRISTMAS TREE f1
YOU SET US UP @I LIED
TALK TO THE HAND f1

HEY CHRISTMAS TREE f2
YOU SET US UP @NO PROBLEMO

HEY CHRISTMAS TREE f3
YOU SET US UP @I LIED

STICK AROUND @NO PROBLEMO

GET TO THE CHOPPER f3
HERE IS MY INVITATION f1
GET UP f2
ENOUGH TALK
TALK TO THE HAND f3

GET TO THE CHOPPER f1
HERE IS MY INVITATION f2
ENOUGH TALK

GET TO THE CHOPPER f2
HERE IS MY INVITATION f3
ENOUGH TALK

CHILL

YOU HAVE BEEN TERMINATED


;max input range equals 0 to 0xFFFFFFFF.

jsr GetInput		;unimplemented routine to get user input for a positive (nonzero) integer.
                        ;output of this routine will be in D0.

MOVE.L D0,D1            ;D1 will be used for temp storage.
MOVE.L #1,D2		;start with 1.

computeFactors:
DIVU D2,D1              ;remainder is in top 2 bytes, quotient in bottom 2.
MOVE.L D1,D3		;temporarily store into D3 to check the remainder
SWAP D3			;swap the high and low words of D3. Now bottom 2 bytes contain remainder.
CMP.W #0,D3		;is the bottom word equal to 0?
BNE D2_Wasnt_A_Divisor	;if not, D2 was not a factor of D1.

JSR PrintD2		;unimplemented routine to print D2 to the screen as a decimal number.

D2_Wasnt_A_Divisor:
MOVE.L D0,D1            ;restore D1.
ADDQ.L #1,D2		;increment D2
CMP.L D2,D1             ;is D2 now greater than D1?
BLS computeFactors      ;if not, loop again

;end of program


def perim_equal(p1, p2):
    # Cheap tests first
    if len(p1) != len(p2) or set(p1) != set(p2):
        return False
    if any(p2 == (p1[n:] + p1[:n]) for n in range(len(p1))):
        return True
    p2 = p2[::-1] # not inplace
    return any(p2 == (p1[n:] + p1[:n]) for n in range(len(p1)))

def edge_to_periphery(e):
    edges = sorted(e)
    p = list(edges.pop(0)) if edges else []
    last = p[-1] if p else None
    while edges:
        for n, (i, j) in enumerate(edges):
            if i == last:
                p.append(j)
                last = j
                edges.pop(n)
                break
            elif j == last:
                p.append(i)
                last = i
                edges.pop(n)
                break
        else:
            #raise ValueError(f'Invalid edge format: {e}')
            return ">>>Error! Invalid edge format<<<"
    return p[:-1]

if __name__ == '__main__':
    print('Perimeter format equality checks:')
    for eq_check in [
            { 'Q': (8, 1, 3),
              'R': (1, 3, 8)},
            { 'U': (18, 8, 14, 10, 12, 17, 19),
              'V': (8, 14, 10, 12, 17, 19, 18)} ]:
        (n1, p1), (n2, p2) = eq_check.items()
        eq = '==' if perim_equal(p1, p2) else '!='
        print(' ', n1, eq, n2)

    print('\nEdge to perimeter format translations:')
    edge_d = {
     'E': {(1, 11), (7, 11), (1, 7)},
     'F': {(11, 23), (1, 17), (17, 23), (1, 11)},
     'G': {(8, 14), (17, 19), (10, 12), (10, 14), (12, 17), (8, 18), (18, 19)},
     'H': {(1, 3), (9, 11), (3, 11), (1, 11)}
            }
    for name, edges in edge_d.items():
        print(f"  {name}: {edges}\n     -> {edge_to_periphery(edges)}")


fib: $[x][
	if? x<2 [1]
	else [(fib x-1) + (fib x-2)]
]

loop 1..25 [x][
	print ["Fibonacci of" x "=" fib x]
]


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program factorst64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

.equ CHARPOS,       '@'

/*******************************************/
/* Initialized data                        */
/*******************************************/
.data
szMessDeb:         .ascii "Factors of : @ are : \n"
szMessFactor:      .asciz "@ \n"
szCarriageReturn:  .asciz "\n"
/*******************************************/
/* UnInitialized data                      */
/*******************************************/
.bss
sZoneConversion:        .skip 100
/*******************************************/
/*  code section                           */
/*******************************************/
.text
.global main
main:                             // entry of program

    mov x0,#100
    bl factors
    mov x0,#97
    bl factors
    ldr x0,qNumber
    bl factors

100:                             // standard end of the program
    mov x0, #0                   // return code
    mov x8, #EXIT                // request to exit program
    svc 0                        // perform the system call

qNumber:               .quad 32767
qAdrszCarriageReturn:  .quad szCarriageReturn
/******************************************************************/
/*     calcul factors of number                                  */
/******************************************************************/
/* x0 contains the number to factorize */
factors:
    stp x1,lr,[sp,-16]!         // save  registers
    stp x2,x3,[sp,-16]!         // save  registers

    mov x5,x0                   // limit calcul
    ldr x1,qAdrsZoneConversion  // conversion register in decimal string
    bl conversion10S
    ldr x0,qAdrszMessDeb        // display message
    ldr x1,qAdrsZoneConversion
    bl strInsertAtChar
    bl affichageMess
    mov x6,#1                   // counter loop
1:   // loop
    udiv x0,x5,x6               // division
    msub x3,x0,x6,x5            // compute remainder
    cbnz x3,2f                  // remainder not = zero -> loop
                                // display result if yes
    mov x0,x6
    ldr x1,qAdrsZoneConversion
    bl conversion10S
    ldr x0,qAdrszMessFactor     // display message
    ldr x1,qAdrsZoneConversion
    bl strInsertAtChar
    bl affichageMess
2:
    add x6,x6,#1                // add 1 to loop counter
    cmp x6,x5                   // <=  number ?
    ble 1b                      // yes loop
100:
    ldp x2,x3,[sp],16           // restaur  2 registers
    ldp x1,lr,[sp],16           // restaur  2 registers
    ret

qAdrszMessDeb:        .quad szMessDeb
qAdrszMessFactor:     .quad szMessFactor
qAdrsZoneConversion:  .quad sZoneConversion
/******************************************************************/
/*   insert string at character insertion  */
/******************************************************************/
/* x0 contains the address of string 1 */
/* x1 contains the address of insertion string   */
/* x0 return the address of new string  on the heap */
/* or -1 if error   */
strInsertAtChar:
    stp x2,lr,[sp,-16]!                      // save  registers
    stp x3,x4,[sp,-16]!                      // save  registers
    stp x5,x6,[sp,-16]!                      // save  registers
    stp x7,x8,[sp,-16]!                      // save  registers
    mov x3,#0                                // length counter
1:                                           // compute length of string 1
    ldrb w4,[x0,x3]
    cmp w4,#0
    cinc  x3,x3,ne                           // increment to one if not equal
    bne 1b                                   // loop if not equal
    mov x5,#0                                // length counter insertion string
2:                                           // compute length to insertion string
    ldrb w4,[x1,x5]
    cmp x4,#0
    cinc  x5,x5,ne                           // increment to one if not equal
    bne 2b                                   // and loop
    cmp x5,#0
    beq 99f                                  // string empty -> error
    add x3,x3,x5                             // add 2 length
    add x3,x3,#1                             // +1 for final zero
    mov x6,x0                                // save address string 1
    mov x0,#0                                // allocation place heap
    mov x8,BRK                               // call system 'brk'
    svc #0
    mov x5,x0                                // save address heap for output string
    add x0,x0,x3                             // reservation place x3 length
    mov x8,BRK                               // call system 'brk'
    svc #0
    cmp x0,#-1                               // allocation error
    beq 99f

    mov x2,0
    mov x4,0
3:                                           // loop copy string begin
    ldrb w3,[x6,x2]
    cmp w3,0
    beq 99f
    cmp w3,CHARPOS                           // insertion character ?
    beq 5f                                   // yes
    strb w3,[x5,x4]                          // no store character in output string
    add x2,x2,1
    add x4,x4,1
    b 3b                                     // and loop
5:                                           // x4 contains position insertion
    add x8,x4,1                              // init index character output string
                                             // at position insertion + one
    mov x3,#0                                // index load characters insertion string
6:
    ldrb w0,[x1,x3]                          // load characters insertion string
    cmp w0,#0                                // end string ?
    beq 7f                                   // yes
    strb w0,[x5,x4]                          // store in output string
    add x3,x3,#1                             // increment index
    add x4,x4,#1                             // increment output index
    b 6b                                     // and loop
7:                                           // loop copy end string
    ldrb w0,[x6,x8]                          // load other character string 1
    strb w0,[x5,x4]                          // store in output string
    cmp x0,#0                                // end string 1 ?
    beq 8f                                   // yes -> end
    add x4,x4,#1                             // increment output index
    add x8,x8,#1                             // increment index
    b 7b                                     // and loop
8:
    mov x0,x5                                // return output string address
    b 100f
99:                                          // error
    mov x0,#-1
100:
    ldp x7,x8,[sp],16                        // restaur  2 registers
    ldp x5,x6,[sp],16                        // restaur  2 registers
    ldp x3,x4,[sp],16                        // restaur  2 registers
    ldp x2,lr,[sp],16                        // restaur  2 registers
    ret

/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


(defun factors-r (n i)
   (declare (xargs :measure (nfix (- n i))))
   (cond ((zp (- n i))
          (list n))
         ((= (mod n i) 0)
          (cons i (factors-r n (1+ i))))
         (t (factors-r n (1+ i)))))

(defun factors (n)
   (factors-r n 1))


PROC PrintFactors(CARD a)
  BYTE notFirst
  CARD p

  p=1 notFirst=0
  WHILE p<=a
  DO
    IF a MOD p=0 THEN
      IF notFirst THEN
        Print(", ")
      FI
      notFirst=1
      PrintC(p)
    FI
    p==+1
  OD
RETURN

PROC Test(CARD a)
  PrintF("Factors of %U: ",a)
  PrintFactors(a)
  PutE()
RETURN

PROC Main()
  Test(1)
  Test(101)
  Test(666)
  Test(1977)
  Test(2021)
  Test(6502)
  Test(12345)
RETURN


function factor(n:uint):Vector.<uint>
{
	var factors:Vector.<uint> = new Vector.<uint>();
	for(var i:uint = 1; i <= n; i++)
		if(n % i == 0)factors.push(i);
	return factors;
}


import "./sort" for Sort
import "./seq" for Lst
import "./fmt" for Fmt

// Check two perimeters are equal.
var perimEqual = Fn.new { |p1, p2|
    var le = p1.count
    if (le != p2.count) return false
    for (p in p1) {
        if (!p2.contains(p)) return false
    }
    // use copy to avoid mutating 'p1'
    var c = p1.toList
    for (r in 0..1) {
        for (i in 0...le) {
            if (Lst.areEqual(c, p2)) return true
            // do circular shift to right
            Lst.rshift(c)
        }
        // now process in opposite direction
        Lst.reverse(c) // reverses 'c' in place
    }
    return false
}

var faceToPerim = Fn.new { |face|
    // use copy to avoid mutating 'face'
    var le = face.count
    if (le == 0) return []
    var edges = List.filled(le, null)
    for (i in 0...le) {
        // check edge pairs are in correct order
        if (face[i][1] <= face[i][0]) return []
        edges[i] = [face[i][0], face[i][1]]
    }
    // sort edges in ascending order
    var cmp = Fn.new { |e1, e2|
        if (e1[0] != e2[0]) {
            return (e1[0] - e2[0]).sign
        }
        return (e1[1] - e2[1]).sign
    }
    Sort.insertion(edges, cmp)
    var first = edges[0][0]
    var last  = edges[0][1]
    var perim = [first, last]
    // remove first edge
    edges.removeAt(0)
    le = le - 1
    while (le > 0) {
        var i = 0
        var outer = false
        var cont = false
        for (e in edges) {
            var found = false
            if (e[0] == last) {
                perim.add(e[1])
                last = e[1]
                found = true
            } else if (e[1] == last) {
                perim.add(e[0])
                last = e[0]
                found = true
            }
            if (found) {
                // remove i'th edge
                edges.removeAt(i)
                le = le - 1
                if (last == first) {
                    if (le == 0) {
                        outer = true
                        break
                    } else {
                        return []
                    }
                }
                cont = true
                break
            }
            i = i + 1
        }
        if (outer && !cont) break
    }
    return perim[0..-2]
}

System.print("Perimeter format equality checks:")
var areEqual = perimEqual.call([8, 1, 3], [1, 3, 8])
System.print("  Q == R is %(areEqual)")
areEqual = perimEqual.call([18, 8, 14, 10, 12, 17, 19], [8, 14, 10, 12, 17, 19, 18])
System.print("  U == V is %(areEqual)")
var e = [[7, 11], [1, 11], [1, 7]]
var f = [[11, 23], [1, 17], [17, 23], [1, 11]]
var g = [[8, 14], [17, 19], [10, 12], [10, 14], [12, 17], [8, 18], [18, 19]]
var h = [[1, 3], [9, 11], [3, 11], [1, 11]]
System.print("\nEdge to perimeter format translations:")
var i = 0
for (face in [e, f, g, h]) {
    var perim = faceToPerim.call(face)
    if (perim.isEmpty) {
        Fmt.print("  $c => Invalid edge format", i + 69) // 'E' is ASCII 69
    } else {
        Fmt.print("  $c => $n", i + 69, perim)
    }
}


fun fib_rec(n: int): int =
  if n >= 2 then fib_rec(n-1) + fib_rec(n-2) else n


with Ada.Text_IO;
with Ada.Command_Line;
procedure Factors is
   Number  : Positive;
   Test_Nr : Positive := 1;
begin
   if Ada.Command_Line.Argument_Count /= 1 then
      Ada.Text_IO.Put (Ada.Text_IO.Standard_Error, "Missing argument!");
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      return;
   end if;
   Number := Positive'Value (Ada.Command_Line.Argument (1));
   Ada.Text_IO.Put ("Factors of" & Positive'Image (Number) & ": ");
   loop
      if Number mod Test_Nr = 0 then
         Ada.Text_IO.Put (Positive'Image (Test_Nr) & ",");
      end if;
      exit when Test_Nr ** 2 >= Number;
      Test_Nr := Test_Nr + 1;
   end loop;
   Ada.Text_IO.Put_Line (Positive'Image (Number) & ".");
end Factors;


fcn perimSame(p1, p2){
   if(p1.len() != p2.len()) return(False);
   False == p1.filter1('wrap(p){ (not p2.holds(p)) })
}

fcn edge_to_periphery(faces){
   edges:=faces.copy().sort(fcn(a,b){ if(a[0]!=b[0]) a[0]<b[0] else a[1]<b[1] });
   p,last := ( if(edges) edges.pop(0).copy() else T ), ( p and p[-1] or Void );
   while(edges){
      foreach i,j in (edges){
         if     (i==last){ p.append( last=j ); edges.del(__iWalker.idx); break; }
         else if(j==last){ p.append( last=i ); edges.del(__iWalker.idx); break; }
      }
      fallthrough{ return(">>>Error! Invalid edge format<<<") }
   }
   p[0,-1]	// last element not part of result
}


Loop, 5
  MsgBox % fib(A_Index)
Return

fib(n)
{
  If (n < 2)
    Return n
  i := last := this := 1
  While (i <= n)
  {
    new := last + this
    last := this
    this := new
    i++
  }
  Return this
}


import math

function factor (n:int) {
    var result = []
    function append (v) {
        if (!(v in result)) {
            result.append (v)
        }
    }
    var sqrt = cast<int>(Math.sqrt (n))
    append (1)
    for (var i = n-1 ; i >= sqrt ; i--) {
        if ((n % i) == 0) {
            append (i)
            append (n/i)
        }
    }
    append (n)
    return result.sort()
}

function printvec (vec) {
    var comma = ""
    print ("[")
    foreach v vec {
        print (comma + v)
        comma = ", "
    }
    println ("]")
}

printvec (factor (45))
printvec (factor (25))
printvec (factor (100))


MODE YIELDINT = PROC(INT)VOID;

PROC gen factors = (INT n, YIELDINT yield)VOID: (
  FOR i FROM 1 TO ENTIER sqrt(n) DO
    IF n MOD i = 0 THEN
      yield(i);
      INT other = n OVER i;
      IF i NE other THEN yield(n OVER i) FI
    FI
  OD
);

[]INT nums2factor = (45, 53, 64);

FOR i TO UPB nums2factor DO
  INT num = nums2factor[i];
  STRING sep := ": ";
  print(num);
# FOR INT j IN # gen factors(num, # ) DO ( #
##   (INT j)VOID:(
       print((sep,whole(j,0)));
       sep:=", "
# OD # ));
  print(new line)
OD


#AutoIt Version: 3.2.10.0
$n0 = 0
$n1 = 1
$n = 10
MsgBox (0,"Iterative Fibonacci ", it_febo($n0,$n1,$n))

Func it_febo($n_0,$n_1,$N)
   $first = $n_0
   $second = $n_1
   $next = $first + $second
   $febo = 0
   For $i = 1 To $N-3
      $first = $second
      $second = $next
      $next = $first + $second
   Next
   if $n==0 Then
      $febo = 0
   ElseIf $n==1 Then
      $febo = $n_0
   ElseIf $n==2 Then
      $febo = $n_1
   Else
      $febo = $next
   EndIf
   Return $febo
EndFunc


begin
    % return the factors of n ( n should be >= 1 ) in the array factor       %
    % the bounds of factor should be 0 :: len (len must be at least 1)       %
    % the number of factors will be returned in factor( 0 )                  %
    procedure getFactorsOf ( integer value n
                           ; integer array factor( * )
                           ; integer value len
                           ) ;
    begin
        for i := 0 until len do factor( i ) := 0;
        if n >= 1 and len >= 1 then begin
            integer pos, lastFactor;
            factor( 0 ) := factor( 1 ) := pos := 1;
            % find the factors up to sqrt( n )                               %
            for f := 2 until truncate( sqrt( n ) ) + 1 do begin
                if ( n rem f ) = 0 and pos <= len then begin
                    % found another factor and there's room to store it      %
                    pos           := pos + 1;
                    factor( 0   ) := pos;
                    factor( pos ) := f
                end if_found_factor
            end for_f;
            % find the factors above sqrt( n )                               %
            lastFactor := factor( factor( 0 ) );
            for f := factor( 0 ) step -1 until 1 do begin
                integer newFactor;
                newFactor := n div factor( f );
                if newFactor > lastFactor and pos <= len then begin
                    % found another factor and there's room to store it      %
                    pos           := pos + 1;
                    factor( 0   ) := pos;
                    factor( pos ) := newFactor
                end if_found_factor
            end for_f;
        end if_params_ok
    end getFactorsOf ;

    % prpocedure to test getFactorsOf                                        %
    procedure testFactorsOf( integer value n ) ;
    begin
        integer array factor( 0 :: 100 );
        getFactorsOf( n, factor, 100 );
        i_w := 1; s_w := 0; % set output format                              %
        write( n, " has ", factor( 0 ), " factors:" );
        for f := 1 until factor( 0 ) do writeon( " ", factor( f ) )
    end testFactorsOf ;

    % test the factorising                                                   %
    for i := 1 until 100 do testFactorsOf( i )

end.


BEGIN

COMMENT RETURN P MOD Q;
INTEGER FUNCTION MOD (P, Q);
INTEGER P, Q;
BEGIN
    MOD := P - Q * (P / Q);
END;

INTEGER I, N, LIMIT, FOUND, START, DELTA;

WHILE 1 = 1 DO
  BEGIN
    WRITE ("NUMBER TO FACTOR (OR 0 TO QUIT):");
    READ (N);
    IF N = 0 THEN GOTO DONE;
    WRITE ("THE FACTORS ARE:");

    COMMENT CHECK WHETHER NUMBER IS EVEN OR ODD;
    IF MOD(N, 2) = 0 THEN
      BEGIN
        START := 2;
        DELTA := 1;
      END
    ELSE
      BEGIN
        START := 3;
        DELTA := 2;
      END;

    COMMENT TEST POTENTIAL DIVISORS;
    FOUND := 0;
    I := START;
    LIMIT := N / I;
    WHILE I <= LIMIT DO
      BEGIN
        IF MOD(N, I) = 0 THEN
          BEGIN
            WRITEON (I);
            FOUND := FOUND + 1;
          END;
        I := I + DELTA;
        IF FOUND = 0 THEN LIMIT := N / I;
      END;
    IF FOUND = 0 THEN WRITEON (" NONE - THE NUMBER IS PRIME.");
    WRITE("");
  END;

DONE: WRITE ("GOODBYE");

END


-- integerFactors :: Int -> [Int]
on integerFactors(n)
    if n = 1 then
        {1}
    else if 1 > n then
        missing value
    else
        set realRoot to n ^ (1 / 2)
        set intRoot to realRoot as integer
        set blnPerfectSquare to intRoot = realRoot

        -- isFactor :: Int -> Bool
        script isFactor
            on |λ|(x)
                (n mod x) = 0
            end |λ|
        end script

        -- Factors up to square root of n,
        set lows to filter(isFactor, enumFromTo(1, intRoot))

        -- integerQuotient :: Int -> Int
        script integerQuotient
            on |λ|(x)
                (n / x) as integer
            end |λ|
        end script

        -- and quotients of these factors beyond the square root.
        lows & map(integerQuotient, ¬
            items (1 + (blnPerfectSquare as integer)) thru -1 of reverse of lows)
    end if
end integerFactors

--------------------------- TEST -------------------------
on run

    integerFactors(120)

    --> {1, 2, 3, 4, 5, 6, 8, 10, 12, 15, 20, 24, 30, 40, 60, 120}
end run

-------------------- GENERIC FUNCTIONS -------------------

-- enumFromTo :: Int -> Int -> [Int]
on enumFromTo(m, n)
    if n < m then
        set d to -1
    else
        set d to 1
    end if
    set lst to {}
    repeat with i from m to n by d
        set end of lst to i
    end repeat
    return lst
end enumFromTo

-- filter :: (a -> Bool) -> [a] -> [a]
on filter(f, xs)
    tell mReturn(f)
        set lst to {}
        set lng to length of xs
        repeat with i from 1 to lng
            set v to item i of xs
            if |λ|(v, i, xs) then set end of lst to v
        end repeat
        return lst
    end tell
end filter

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn


Lbl FIB
r₁→N
0→I
1→J
For(K,1,N)
 I+J→T
 J→I
 T→J
End
J
Return


(= divisor (fn (num)
   (= dlist '())
   (when (is 1 num) (= dlist '(1 0)))
   (when (is 2 num) (= dlist '(2 1)))
   (unless (or (is 1 num) (is 2 num))
   (up i 1 (+ 1 (/ num 2))
     (if (is 0 (mod num i))
         (push i dlist)))
   (= dlist (cons num dlist)))
   dlist))

(map [rev _] (map [divisor _] '(45 53 60 64)))


/* ARM assembly Raspberry PI  */
/*  program factorst.s   */

/* Constantes    */
.equ STDOUT, 1     @ Linux output console
.equ EXIT,   1     @ Linux syscall
.equ WRITE,  4     @ Linux syscall
/* Initialized data */
.data
szMessDeb: .ascii "Factors of :"
sMessValeur:   .fill 12, 1, ' '
                   .asciz "are : \n"
sMessFactor:   .fill 12, 1, ' '
                   .asciz "\n"
szCarriageReturn:  .asciz "\n"

/* UnInitialized data */
.bss

/*  code section */
.text
.global main
main:                /* entry of program  */
    push {fp,lr}    /* saves 2 registers */

    mov r0,#100
    bl factors
    mov r0,#97
    bl factors
    ldr r0,iNumber
    bl factors

100:   /* standard end of the program */
    mov r0, #0                  @ return code
    pop {fp,lr}                 @restaur 2 registers
    mov r7, #EXIT              @ request to exit program
    swi 0                       @ perform the system call

iNumber: .int 32767
iAdrszCarriageReturn:  .int  szCarriageReturn
/******************************************************************/
/*     calcul factors of number                                  */
/******************************************************************/
/* r0 contains the number */
factors:
    push {fp,lr}    			/* save  registres */
    push {r1-r6}    		/* save others registers */
    mov r5,r0    @ limit calcul
    ldr r1,iAdrsMessValeur   @ conversion register in decimal string
    bl conversion10S
    ldr r0,iAdrszMessDeb     @ display message
    bl affichageMess
    mov r6,#1    @ counter loop
1:   @ loop
    mov r0,r5    @ dividende
    mov r1,r6    @ divisor
    bl division
    cmp r3,#0    @ remainder = zero ?
    bne 2f
    @ display result if yes
    mov r0,r6
    ldr r1,iAdrsMessFactor
    bl conversion10S
    ldr r0,iAdrsMessFactor
    bl affichageMess
2:
    add r6,#1      @ add 1 to loop counter
    cmp r6,r5      @ <=  number ?
    ble 1b        @ yes loop
100:
    pop {r1-r6}     		/* restaur others registers */
    pop {fp,lr}    				/* restaur des  2 registres */
    bx lr	        			/* return  */
iAdrsMessValeur: .int sMessValeur
iAdrszMessDeb: .int szMessDeb
iAdrsMessFactor: .int sMessFactor
/******************************************************************/
/*     display text with size calculation                         */
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {fp,lr}    			/* save  registres */
    push {r0,r1,r2,r7}    		/* save others registers */
    mov r2,#0   				/* counter length */
1:      	/* loop length calculation */
    ldrb r1,[r0,r2]  			/* read octet start position + index */
    cmp r1,#0       			/* if 0 its over */
    addne r2,r2,#1   			/* else add 1 in the length */
    bne 1b          			/* and loop */
                                /* so here r2 contains the length of the message */
    mov r1,r0        			/* address message in r1 */
    mov r0,#STDOUT      		/* code to write to the standard output Linux */
    mov r7, #WRITE             /* code call system "write" */
    swi #0                      /* call systeme */
    pop {r0,r1,r2,r7}     		/* restaur others registers */
    pop {fp,lr}    				/* restaur des  2 registres */
    bx lr	        			/* return  */
/*=============================================*/
/* division integer unsigned                */
/*============================================*/
division:
    /* r0 contains N */
    /* r1 contains D */
    /* r2 contains Q */
    /* r3 contains R */
    push {r4, lr}
    mov r2, #0                 /* r2 ? 0 */
    mov r3, #0                 /* r3 ? 0 */
    mov r4, #32                /* r4 ? 32 */
    b 2f
1:
    movs r0, r0, LSL #1    /* r0 ? r0 << 1 updating cpsr (sets C if 31st bit of r0 was 1) */
    adc r3, r3, r3         /* r3 ? r3 + r3 + C. This is equivalent to r3 ? (r3 << 1) + C */

    cmp r3, r1             /* compute r3 - r1 and update cpsr */
    subhs r3, r3, r1       /* if r3 >= r1 (C=1) then r3 ? r3 - r1 */
    adc r2, r2, r2         /* r2 ? r2 + r2 + C. This is equivalent to r2 ? (r2 << 1) + C */
2:
    subs r4, r4, #1        /* r4 ? r4 - 1 */
    bpl 1b            /* if r4 >= 0 (N=0) then branch to .Lloop1 */

    pop {r4, lr}
    bx lr

/***************************************************/
/*   conversion register in string décimal signed  */
/***************************************************/
/* r0 contains the register   */
/* r1 contains address of conversion area */
conversion10S:
    push {fp,lr}    /* save registers frame and return */
    push {r0-r5}   /* save other registers  */
    mov r2,r1       /* early storage area */
    mov r5,#'+'     /* default sign is + */
    cmp r0,#0       /* négatif number ? */
    movlt r5,#'-'     /* yes sign is - */
    mvnlt r0,r0       /* and inverse in positive value */
    addlt r0,#1
    mov r4,#10   /* area length */
1: /* conversion loop */
    bl divisionpar10 /* division  */
    add r1,#48        /* add 48 at remainder for conversion ascii */
    strb r1,[r2,r4]  /* store byte area r5 + position r4 */
    sub r4,r4,#1      /* previous position */
    cmp r0,#0
    bne 1b	       /* loop if quotient not equal zéro */
    strb r5,[r2,r4]  /* store sign at current position  */
    subs r4,r4,#1   /* previous position */
    blt  100f         /* if r4 < 0  end  */
    /* else complete area with space */
    mov r3,#' '   /* character space */
2:
    strb r3,[r2,r4]  /* store  byte  */
    subs r4,r4,#1   /* previous position */
    bge 2b        /* loop if r4 greather or equal zero */
100:  /*  standard end of function  */
    pop {r0-r5}   /*restaur others registers */
    pop {fp,lr}   /* restaur des  2 registers frame et return  */
    bx lr

/***************************************************/
/*   division par 10   signé                       */
/* Thanks to http://thinkingeek.com/arm-assembler-raspberry-pi/*
/* and   http://www.hackersdelight.org/            */
/***************************************************/
/* r0 contient le dividende   */
/* r0 retourne le quotient */
/* r1 retourne le reste  */
divisionpar10:
  /* r0 contains the argument to be divided by 10 */
   push {r2-r4}   /* save autres registres  */
   mov r4,r0
   ldr r3, .Ls_magic_number_10 /* r1 <- magic_number */
   smull r1, r2, r3, r0   /* r1 <- Lower32Bits(r1*r0). r2 <- Upper32Bits(r1*r0) */
   mov r2, r2, ASR #2     /* r2 <- r2 >> 2 */
   mov r1, r0, LSR #31    /* r1 <- r0 >> 31 */
   add r0, r2, r1         /* r0 <- r2 + r1 */
   add r2,r0,r0, lsl #2   /* r2 <- r0 * 5 */
   sub r1,r4,r2, lsl #1   /* r1 <- r4 - (r2 * 2)  = r4 - (r0 * 10) */
   pop {r2-r4}
   bx lr                  /* leave function */
   .align 4
.Ls_magic_number_10: .word 0x66666667


fib { <- 0 1 { dup <- + -> swap } -> times zap } <


factors: $[num][
	select 1..num [x][
		(num%x)=0
	]
]

print factors 36


$ fib=1;j=1;while((fib<100));do echo $fib;((k=fib+j,fib=j,j=k));done


msgbox, % factors(45) "`n" factors(53) "`n" factors(64)

Factors(n)
{  Loop, % floor(sqrt(n))
   {  v := A_Index = 1 ? 1 "," n : mod(n,A_Index) ? v : v "," A_Index "," n//A_Index
   }
   Sort, v, N U D,
   Return, v
}


;AutoIt Version: 3.2.10.0
$num = 45
MsgBox (0,"Factors", "Factors of " & $num & " are: " & factors($num))
consolewrite ("Factors of " & $num & " are: " & factors($num))
Func factors($intg)
   $ls_factors=""
   For $i = 1 to $intg/2
      if ($intg/$i - int($intg/$i))=0 Then
	 $ls_factors=$ls_factors&$i &", "
      EndIf
   Next
   Return $ls_factors&$intg
EndFunc


F is_prime(a)
   I a == 2 {R 1B}
   I a < 2 | a % 2 == 0 {R 0B}
   L(i) (3 .. Int(sqrt(a))).step(2)
      I a % i == 0
         R 0B
   R 1B

F m_factor(p)
   V max_k = 16384 I/ p
   L(k) 0 .< max_k
      V q = 2 * p * k + 1
      I !is_prime(q)
         L.continue
      E I q % 8 != 1 & q % 8 != 7
         L.continue
      E I pow(2, p, q) == 1
         R q
   R 0

V exponent = Int(input(‘Enter exponent of Mersenne number: ’))
I !is_prime(exponent)
   print(‘Exponent is not prime: #.’.format(exponent))
E
   V factor = m_factor(exponent)
   I factor == 0
      print(‘No factor found for M#.’.format(exponent))
   E
      print(‘M#. has a factor: #.’.format(exponent, factor))


# syntax: GAWK -f FACTORS_OF_AN_INTEGER.AWK
BEGIN {
    print("enter a number or C/R to exit")
}
{   if ($0 == "") { exit(0) }
    if ($0 !~ /^[0-9]+$/) {
      printf("invalid: %s\n",$0)
      next
    }
    n = $0
    printf("factors of %s:",n)
    for (i=1; i<=n; i++) {
      if (n % i == 0) {
        printf(" %d",i)
      }
    }
    printf("\n")
}


DECLARE SUB factor (what AS INTEGER)

REDIM SHARED factors(0) AS INTEGER

DIM i AS INTEGER, L AS INTEGER

INPUT "Gimme a number"; i

factor i

PRINT factors(0);
FOR L = 1 TO UBOUND(factors)
    PRINT ","; factors(L);
NEXT
PRINT

SUB factor (what AS INTEGER)
    DIM tmpint1 AS INTEGER
    DIM L0 AS INTEGER, L1 AS INTEGER

    REDIM tmp(0) AS INTEGER
    REDIM factors(0) AS INTEGER
    factors(0) = 1

    FOR L0 = 2 TO what
        IF (0 = (what MOD L0)) THEN
            'all this REDIMing and copying can be replaced with:
            'REDIM PRESERVE factors(UBOUND(factors)+1)
            'in languages that support the PRESERVE keyword
            REDIM tmp(UBOUND(factors)) AS INTEGER
            FOR L1 = 0 TO UBOUND(factors)
                tmp(L1) = factors(L1)
            NEXT
            REDIM factors(UBOUND(factors) + 1)
            FOR L1 = 0 TO UBOUND(factors) - 1
                factors(L1) = tmp(L1)
            NEXT
            factors(UBOUND(factors)) = L0
        END IF
    NEXT
END SUB