package require tdom
set d [dom createDocument root]
set root [$d documentElement]
$root appendChild [$d createElement element]
[$root firstChild] appendChild [$d createTextNode "Some text here"]
$d asXML


class XmlDocument {
    construct new(root) {
        _root = root
    }

    toString { "<?xml version=\"1.0\" ?>\n%(_root.toString(0))" }
}

class XmlElement {
    construct new(name, text) {
        _name = name
        _text = text
        _children = []
    }

    name     { _name }
    text     { _text }
    children { _children }

    addChild(child) { _children.add(child) }

    toString(level) {
        var indent = "    "
        var s = indent * level + "<%(name)>\n"
        if (_text != "") s = s + indent * (level + 1) + _text + "\n"
        for (c in _children) {
            s = s + c.toString(level+1) + "\n"
        }
        return s + indent * level + "</%(name)>"
    }
}

var root  = XmlElement.new("root", "")
var child = XmlElement.new("element", "Some text here")
root.addChild(child)
var doc = XmlDocument.new(root)
System.print(doc)


<p:pipeline xmlns:p="http://www.w3.org/ns/xproc" version="1.0">
  <p:identity>
    <p:input port="source">
      <p:inline>
        <root>
          <element>
            Some text here
          </element>
        </root>
      </p:inline>
    </p:input>
  </p:identity>
</p:pipeline>


<root>
  <element>
    Some text here
  </element>
</root>


<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
  <xsl:output method="xml" indent="yes" />
  <xsl:template match="/">   <!-- replace the root of the incoming document with our own model -->
    <xsl:element name="root">
      <xsl:element name="element">
        <xsl:text>Some text here</xsl:text>
      </xsl:element>
    </xsl:element>
  </xsl:template>
</xsl:stylesheet>


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

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

/*******************************************/
/* Structures                               */
/********************************************/
/* structure function*/
    .struct  0
func_fn:                    // next element
    .struct  func_fn + 8
func_f_:                    // next element
    .struct  func_f_ + 8
func_num:
    .struct  func_num + 8
func_fin:

/* Initialized data */
.data
szMessStartPgm:            .asciz "Program start \n"
szMessEndPgm:              .asciz "Program normal end.\n"
szMessError:               .asciz "\033[31mError Allocation !!!\n"

szFactorielle:             .asciz "Function factorielle : \n"
szFibonacci:               .asciz "Function Fibonacci : \n"
szCarriageReturn:          .asciz "\n"

/* datas message display */
szMessResult:            .ascii "Result value : @ \n"

/* UnInitialized data */
.bss
sZoneConv:                .skip 100
/*  code section */
.text
.global main
main:                                           // program start
    ldr x0,qAdrszMessStartPgm                   // display start message
    bl affichageMess
    adr x0,facFunc                              // function factorielle address
    bl YFunc                                    // create Ycombinator
    mov x19,x0                                   // save Ycombinator
    ldr x0,qAdrszFactorielle                    // display message
    bl affichageMess
    mov x20,#1                                   // loop counter
1:  // start loop
    mov x0,x20
    bl numFunc                                  // create number structure
    cmp x0,#-1                                  // allocation error ?
    beq 99f
    mov x1,x0                                   // structure number address
    mov x0,x19                                  // Ycombinator address
    bl callFunc                                 // call
    ldr x0,[x0,#func_num]                       // load result
    ldr x1,qAdrsZoneConv                        // and convert ascii string
    bl conversion10S                            // decimal conversion
    ldr x0,qAdrszMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc                       // insert result at @ character
    bl affichageMess                            // display message final

    add x20,x20,#1                              // increment loop counter
    cmp x20,#10                                 // end ?
    ble 1b                                      // no -> loop
/*********Fibonacci  *************/
    adr x0,fibFunc                              // function fibonacci address
    bl YFunc                                    // create Ycombinator
    mov x19,x0                                  // save Ycombinator
    ldr x0,qAdrszFibonacci                      // display message
    bl affichageMess
    mov x20,#1                                  // loop counter
2:  // start loop
    mov x0,x20
    bl numFunc                                  // create number structure
    cmp x0,#-1                                  // allocation error ?
    beq 99f
    mov x1,x0                                   // structure number address
    mov x0,x19                                   // Ycombinator address
    bl callFunc                                 // call
    ldr x0,[x0,#func_num]                       // load result
    ldr x1,qAdrsZoneConv                        // and convert ascii string
    bl conversion10S
    ldr x0,qAdrszMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc                       // insert result at @ character
    bl affichageMess
    add x20,x20,#1                                   // increment loop counter
    cmp x20,#10                                  // end ?
    ble 2b                                      // no -> loop
    ldr x0,qAdrszMessEndPgm                     // display end message
    bl affichageMess
    b 100f
99:                                             // display error message
    ldr x0,qAdrszMessError
    bl affichageMess
100:                                            // standard end of the program
    mov x0,0                                    // return code
    mov x8,EXIT                                 // request to exit program
    svc 0                                       // perform system call
qAdrszMessStartPgm:        .quad szMessStartPgm
qAdrszMessEndPgm:          .quad szMessEndPgm
qAdrszFactorielle:         .quad szFactorielle
qAdrszFibonacci:           .quad szFibonacci
qAdrszMessError:           .quad szMessError
qAdrszCarriageReturn:      .quad szCarriageReturn
qAdrszMessResult:          .quad szMessResult
qAdrsZoneConv:             .quad sZoneConv
/******************************************************************/
/*     factorielle function                         */
/******************************************************************/
/* x0 contains the Y combinator address  */
/* x1 contains the number structure  */
facFunc:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    mov x2,x0                   // save Y combinator address
    ldr x0,[x1,#func_num]       // load number
    cmp x0,#1                   // > 1 ?
    bgt 1f                      // yes
    mov x0,#1                   // create structure number value 1
    bl numFunc
    b 100f
1:
    mov x3,x0                   // save number
    sub x0,x0,#1                   // decrement number
    bl numFunc                  // and create new structure number
    cmp x0,#-1                  // allocation error ?
    beq 100f
    mov x1,x0                   // new structure number -> param 1
    ldr x0,[x2,#func_f_]        // load function address to execute
    bl callFunc                 // call
    ldr x1,[x0,#func_num]       // load new result
    mul x0,x1,x3                // and multiply by precedent
    bl numFunc                  // and create new structure number
                                // and return her address in x0
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     fibonacci function                         */
/******************************************************************/
/* x0 contains the Y combinator address  */
/* x1 contains the number structure  */
fibFunc:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    stp x4,x5,[sp,-16]!            // save  registers
    mov x2,x0                   // save Y combinator address
    ldr x0,[x1,#func_num]       // load number
    cmp x0,#1                   // > 1 ?
    bgt 1f                      // yes
    mov x0,#1                   // create structure number value 1
    bl numFunc
    b 100f
1:
    mov x3,x0                   // save number
    sub x0,x0,#1                // decrement number
    bl numFunc                  // and create new structure number
    cmp x0,#-1                  // allocation error ?
    beq 100f
    mov x1,x0                   // new structure number -> param 1
    ldr x0,[x2,#func_f_]        // load function address to execute
    bl callFunc                 // call
    ldr x4,[x0,#func_num]       // load new result
    sub x0,x3,#2                // new number - 2
    bl numFunc                  // and create new structure number
    cmp x0,#-1                  // allocation error ?
    beq 100f
    mov x1,x0                   // new structure number -> param 1
    ldr x0,[x2,#func_f_]        // load function address to execute
    bl callFunc                 // call
    ldr x1,[x0,#func_num]       // load new result
    add x0,x1,x4                // add two results
    bl numFunc                  // and create new structure number
                                // and return her address in x0
100:
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     call function                         */
/******************************************************************/
/* x0 contains the address of the function  */
/* x1 contains the address of the function 1 */
callFunc:
    stp x2,lr,[sp,-16]!            // save  registers
    ldr x2,[x0,#func_fn]           // load function address to execute
    blr x2                         // and call it
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     create Y combinator function                         */
/******************************************************************/
/* x0 contains the address of the function  */
YFunc:
    stp x1,lr,[sp,-16]!            // save  registers
    mov x1,#0
    bl newFunc
    cmp x0,#-1                     // allocation error ?
    beq 100f
    str x0,[x0,#func_f_]           // store function and return in x0
100:
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     create structure number function                         */
/******************************************************************/
/* x0 contains the number  */
numFunc:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    mov x2,x0                      // save number
    mov x0,#0                      // function null
    mov x1,#0                      // function null
    bl newFunc
    cmp x0,#-1                     // allocation error ?
    beq 100f
    str x2,[x0,#func_num]          // store number in new structure
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     new function                                               */
/******************************************************************/
/* x0 contains the function address   */
/* x1 contains the function address 1   */
newFunc:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x3,x4,[sp,-16]!            // save  registers
    stp x5,x8,[sp,-16]!            // save  registers
    mov x4,x0                      // save address
    mov x5,x1                      // save adresse 1
                                   // allocation place on the heap
    mov x0,#0                      // allocation place heap
    mov x8,BRK                     // call system 'brk'
    svc #0
    mov x6,x0                      // save address heap for output string
    add x0,x0,#func_fin            // reservation place one element
    mov x8,BRK                     // call system 'brk'
    svc #0
    cmp x0,#-1                     // allocation error
    beq 100f
    mov x0,x6
    str x4,[x0,#func_fn]           // store address
    str x5,[x0,#func_f_]
    str xzr,[x0,#func_num]         // store zero to number
100:
    ldp x5,x8,[sp],16              // restaur  2 registers
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


BEGIN
  MODE F = PROC(INT)INT;
  MODE Y = PROC(Y)F;

# compare python Y = lambda f: (lambda x: x(x)) (lambda y: f( lambda *args: y(y)(*args)))#
  PROC y =      (PROC(F)F f)F: (  (Y x)F: x(x)) (  (Y z)F: f((INT arg )INT: z(z)( arg )));

  PROC fib = (F f)F: (INT n)INT: CASE n IN n,n OUT f(n-1) + f(n-2) ESAC;

  FOR i TO 10 DO print(y(fib)(i)) OD
END


-- Y COMBINATOR ---------------------------------------------------------------

on |Y|(f)
    script
        on |λ|(y)
            script
                on |λ|(x)
                    y's |λ|(y)'s |λ|(x)
                end |λ|
            end script

            f's |λ|(result)
        end |λ|
    end script

    result's |λ|(result)
end |Y|

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

    -- Factorial
    script fact
        on |λ|(f)
            script
                on |λ|(n)
                    if n = 0 then return 1
                    n * (f's |λ|(n - 1))
                end |λ|
            end script
        end |λ|
    end script

    -- Fibonacci
    script fib
        on |λ|(f)
            script
                on |λ|(n)
                    if n = 0 then return 0
                    if n = 1 then return 1
                    (f's |λ|(n - 2)) + (f's |λ|(n - 1))
                end |λ|
            end script
        end |λ|
    end script

    {facts:map(|Y|(fact), enumFromTo(0, 11)), fibs:map(|Y|(fib), enumFromTo(0, 20))}

    --> {facts:{1, 1, 2, 6, 24, 120, 720, 5040, 40320, 362880, 3628800, 39916800},

    --> fibs:{0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987,
    --           1597, 2584, 4181, 6765}}

end run

-- GENERIC FUNCTIONS FOR TEST -------------------------------------------------

-- 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

-- 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

-- 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


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

/* REMARK 1 : this program use routines in a include file
   see task Include a file language arm assembly
   for the routine affichageMess conversion10
   see at end of this program the instruction include */

/* Constantes    */
.equ STDOUT, 1                           @ Linux output console
.equ EXIT,   1                           @ Linux syscall
.equ WRITE,  4                           @ Linux syscall

/*******************************************/
/* Structures                               */
/********************************************/
/* structure function*/
    .struct  0
func_fn:                    @ next element
    .struct  func_fn + 4
func_f_:                    @ next element
    .struct  func_f_ + 4
func_num:
    .struct  func_num + 4
func_fin:

/* Initialized data */
.data
szMessStartPgm:            .asciz "Program start \n"
szMessEndPgm:              .asciz "Program normal end.\n"
szMessError:               .asciz "\033[31mError Allocation !!!\n"

szFactorielle:             .asciz "Function factorielle : \n"
szFibonacci:               .asciz "Function Fibonacci : \n"
szCarriageReturn:          .asciz "\n"

/* datas message display */
szMessResult:            .ascii "Result value :"
sValue:                  .space 12,' '
                         .asciz "\n"

/* UnInitialized data */
.bss

/*  code section */
.text
.global main
main:                                           @ program start
    ldr r0,iAdrszMessStartPgm                   @ display start message
    bl affichageMess
    adr r0,facFunc                              @ function factorielle address
    bl YFunc                                    @ create Ycombinator
    mov r5,r0                                   @ save Ycombinator
    ldr r0,iAdrszFactorielle                    @ display message
    bl affichageMess
    mov r4,#1                                   @ loop counter
1:  @ start loop
    mov r0,r4
    bl numFunc                                  @ create number structure
    cmp r0,#-1                                  @ allocation error ?
    beq 99f
    mov r1,r0                                   @ structure number address
    mov r0,r5                                   @ Ycombinator address
    bl callFunc                                 @ call
    ldr r0,[r0,#func_num]                       @ load result
    ldr r1,iAdrsValue                           @ and convert ascii string
    bl conversion10
    ldr r0,iAdrszMessResult                     @ display result message
    bl affichageMess
    add r4,#1                                   @ increment loop counter
    cmp r4,#10                                  @ end ?
    ble 1b                                      @ no -> loop
/*********Fibonacci  *************/
    adr r0,fibFunc                              @ function factorielle address
    bl YFunc                                    @ create Ycombinator
    mov r5,r0                                   @ save Ycombinator
    ldr r0,iAdrszFibonacci                      @ display message
    bl affichageMess
    mov r4,#1                                   @ loop counter
2:  @ start loop
    mov r0,r4
    bl numFunc                                  @ create number structure
    cmp r0,#-1                                  @ allocation error ?
    beq 99f
    mov r1,r0                                   @ structure number address
    mov r0,r5                                   @ Ycombinator address
    bl callFunc                                 @ call
    ldr r0,[r0,#func_num]                       @ load result
    ldr r1,iAdrsValue                           @ and convert ascii string
    bl conversion10
    ldr r0,iAdrszMessResult                     @ display result message
    bl affichageMess
    add r4,#1                                   @ increment loop counter
    cmp r4,#10                                  @ end ?
    ble 2b                                      @ no -> loop
    ldr r0,iAdrszMessEndPgm                     @ display end message
    bl affichageMess
    b 100f
99:                                             @ display error message
    ldr r0,iAdrszMessError
    bl affichageMess
100:                                            @ standard end of the program
    mov r0, #0                                  @ return code
    mov r7, #EXIT                               @ request to exit program
    svc 0                                       @ perform system call
iAdrszMessStartPgm:        .int szMessStartPgm
iAdrszMessEndPgm:          .int szMessEndPgm
iAdrszFactorielle:         .int szFactorielle
iAdrszFibonacci:           .int szFibonacci
iAdrszMessError:           .int szMessError
iAdrszCarriageReturn:      .int szCarriageReturn
iAdrszMessResult:          .int szMessResult
iAdrsValue:                .int sValue
/******************************************************************/
/*     factorielle function                         */
/******************************************************************/
/* r0 contains the Y combinator address  */
/* r1 contains the number structure  */
facFunc:
    push {r1-r3,lr}             @ save  registers
    mov r2,r0                   @ save Y combinator address
    ldr r0,[r1,#func_num]       @ load number
    cmp r0,#1                   @ > 1 ?
    bgt 1f                      @ yes
    mov r0,#1                   @ create structure number value 1
    bl numFunc
    b 100f
1:
    mov r3,r0                   @ save number
    sub r0,#1                   @ decrement number
    bl numFunc                  @ and create new structure number
    cmp r0,#-1                  @ allocation error ?
    beq 100f
    mov r1,r0                   @ new structure number -> param 1
    ldr r0,[r2,#func_f_]        @ load function address to execute
    bl callFunc                 @ call
    ldr r1,[r0,#func_num]       @ load new result
    mul r0,r1,r3                @ and multiply by precedent
    bl numFunc                  @ and create new structure number
                                @ and return her address in r0
100:
    pop {r1-r3,lr}              @ restaur registers
    bx lr                       @ return
/******************************************************************/
/*     fibonacci function                         */
/******************************************************************/
/* r0 contains the Y combinator address  */
/* r1 contains the number structure  */
fibFunc:
    push {r1-r4,lr}             @ save  registers
    mov r2,r0                   @ save Y combinator address
    ldr r0,[r1,#func_num]       @ load number
    cmp r0,#1                   @ > 1 ?
    bgt 1f                      @ yes
    mov r0,#1                   @ create structure number value 1
    bl numFunc
    b 100f
1:
    mov r3,r0                   @ save number
    sub r0,#1                   @ decrement number
    bl numFunc                  @ and create new structure number
    cmp r0,#-1                  @ allocation error ?
    beq 100f
    mov r1,r0                   @ new structure number -> param 1
    ldr r0,[r2,#func_f_]        @ load function address to execute
    bl callFunc                 @ call
    ldr r4,[r0,#func_num]       @ load new result
    sub r0,r3,#2                @ new number - 2
    bl numFunc                  @ and create new structure number
    cmp r0,#-1                  @ allocation error ?
    beq 100f
    mov r1,r0                   @ new structure number -> param 1
    ldr r0,[r2,#func_f_]        @ load function address to execute
    bl callFunc                 @ call
    ldr r1,[r0,#func_num]       @ load new result
    add r0,r1,r4                @ add two results
    bl numFunc                  @ and create new structure number
                                @ and return her address in r0
100:
    pop {r1-r4,lr}              @ restaur registers
    bx lr                       @ return
/******************************************************************/
/*     call function                         */
/******************************************************************/
/* r0 contains the address of the function  */
/* r1 contains the address of the function 1 */
callFunc:
    push {r2,lr}                                @ save  registers
    ldr r2,[r0,#func_fn]                        @ load function address to execute
    blx r2                                      @ and call it
    pop {r2,lr}                                 @ restaur registers
    bx lr                                       @ return
/******************************************************************/
/*     create Y combinator function                         */
/******************************************************************/
/* r0 contains the address of the function  */
YFunc:
    push {r1,lr}                                @ save  registers
    mov r1,#0
    bl newFunc
    cmp r0,#-1                                  @ allocation error ?
    strne r0,[r0,#func_f_]                      @ store function and return in r0
    pop {r1,lr}                                 @ restaur registers
    bx lr                                       @ return
/******************************************************************/
/*     create structure number function                         */
/******************************************************************/
/* r0 contains the number  */
numFunc:
    push {r1,r2,lr}                             @ save  registers
    mov r2,r0                                   @ save number
    mov r0,#0                                   @ function null
    mov r1,#0                                   @ function null
    bl newFunc
    cmp r0,#-1                                  @ allocation error ?
    strne r2,[r0,#func_num]                     @ store number in new structure
    pop {r1,r2,lr}                              @ restaur registers
    bx lr                                       @ return
/******************************************************************/
/*     new function                                               */
/******************************************************************/
/* r0 contains the function address   */
/* r1 contains the function address 1   */
newFunc:
    push {r2-r7,lr}                             @ save  registers
    mov r4,r0                                   @ save address
    mov r5,r1                                   @ save adresse 1
    @ allocation place on the heap
    mov r0,#0                                   @ allocation place heap
    mov r7,#0x2D                                @ call system 'brk'
    svc #0
    mov r3,r0                                   @ save address heap for output string
    add r0,#func_fin                            @ reservation place one element
    mov r7,#0x2D                                @ call system 'brk'
    svc #0
    cmp r0,#-1                                  @ allocation error
    beq 100f
    mov r0,r3
    str r4,[r0,#func_fn]                        @ store address
    str r5,[r0,#func_f_]
    mov r2,#0
    str r2,[r0,#func_num]                       @ store zero to number
100:
    pop {r2-r7,lr}                              @ restaur registers
    bx lr                                       @ return
/***************************************************/
/*      ROUTINES INCLUDE                 */
/***************************************************/
.include "../affichage.inc"


(* ****** ****** *)
//
#include "share/atspre_staload.hats"
//
(* ****** ****** *)
//
fun
myfix
{a:type}
(
 f: lazy(a) -<cloref1> a
) : lazy(a) = $delay(f(myfix(f)))
//
val
fact =
myfix{int-<cloref1>int}
(
lam(ff) => lam(x) => if x > 0 then x * !ff(x-1) else 1
)
(* ****** ****** *)
//
implement main0 () = println! ("fact(10) = ", !fact(10))
//
(* ****** ****** *)


SuperStrict

'Boxed type so we can just use object arrays for argument lists
Type Integer
	Field val:Int
	Function Make:Integer(_val:Int)
		Local i:Integer = New Integer
		i.val = _val
		Return i
	End Function
End Type

'Higher-order function type - just a procedure attached to a scope
Type Func Abstract
	Method apply:Object(args:Object[]) Abstract
End Type

'Function definitions - extend with fields as locals and implement apply as body
Type Scope Extends Func Abstract
	Field env:Scope

	'Constructor - bind an environment to a procedure
	Function lambda:Scope(env:Scope) Abstract

	Method _init:Scope(_env:Scope)	'Helper to keep constructors small
		env = _env ; Return Self
	End Method
End Type

'Based on the following definition:
'(define (Y f)
'    (let ((_r (lambda (r) (f (lambda a (apply (r r) a))))))
'      (_r _r)))

'Y (outer)
Type Y Extends Scope
	Field f:Func	'Parameter - gets closed over

	Function lambda:Scope(env:Scope)	'Necessary due to highly limited constructor syntax
		Return (New Y)._init(env)
	End Function

	Method apply:Func(args:Object[])
		f = Func(args[0])
		Local _r:Func = YInner1.lambda(Self)
		Return Func(_r.apply([_r]))
	End Method
End Type

'First lambda within Y
Type YInner1 Extends Scope
	Field r:Func	'Parameter - gets closed over

	Function lambda:Scope(env:Scope)
		Return (New YInner1)._init(env)
	End Function

	Method apply:Func(args:Object[])
		r = Func(args[0])
		Return Func(Y(env).f.apply([YInner2.lambda(Self)]))
	End Method
End Type

'Second lambda within Y
Type YInner2 Extends Scope
	Field a:Object[]	'Parameter - not really needed, but good for clarity

	Function lambda:Scope(env:Scope)
		Return (New YInner2)._init(env)
	End Function

	Method apply:Object(args:Object[])
		a = args
		Local r:Func = YInner1(env).r
		Return Func(r.apply([r])).apply(a)
	End Method
End Type

'Based on the following definition:
'(define fac (Y (lambda (f)
'                 (lambda (x)
'                   (if (<= x 0) 1 (* x (f (- x 1)))))))

Type FacL1 Extends Scope
	Field f:Func	'Parameter - gets closed over

	Function lambda:Scope(env:Scope)
		Return (New FacL1)._init(env)
	End Function

	Method apply:Object(args:Object[])
		f = Func(args[0])
		Return FacL2.lambda(Self)
	End Method
End Type

Type FacL2 Extends Scope
	Function lambda:Scope(env:Scope)
		Return (New FacL2)._init(env)
	End Function

	Method apply:Object(args:Object[])
		Local x:Int = Integer(args[0]).val
		If x <= 0 Then Return Integer.Make(1) ; Else Return Integer.Make(x * Integer(FacL1(env).f.apply([Integer.Make(x - 1)])).val)
	End Method
End Type

'Based on the following definition:
'(define fib (Y (lambda (f)
'                 (lambda (x)
'                   (if (< x 2) x (+ (f (- x 1)) (f (- x 2)))))))

Type FibL1 Extends Scope
	Field f:Func	'Parameter - gets closed over

	Function lambda:Scope(env:Scope)
		Return (New FibL1)._init(env)
	End Function

	Method apply:Object(args:Object[])
		f = Func(args[0])
		Return FibL2.lambda(Self)
	End Method
End Type

Type FibL2 Extends Scope
	Function lambda:Scope(env:Scope)
		Return (New FibL2)._init(env)
	End Function

	Method apply:Object(args:Object[])
		Local x:Int = Integer(args[0]).val
		If x < 2
			Return Integer.Make(x)
		Else
			Local f:Func = FibL1(env).f
			Local x1:Int = Integer(f.apply([Integer.Make(x - 1)])).val
			Local x2:Int = Integer(f.apply([Integer.Make(x - 2)])).val
			Return Integer.Make(x1 + x2)
		EndIf
	End Method
End Type

'Now test
Local _Y:Func = Y.lambda(Null)

Local fac:Func = Func(_Y.apply([FacL1.lambda(Null)]))
Print Integer(fac.apply([Integer.Make(10)])).val

Local fib:Func = Func(_Y.apply([FibL1.lambda(Null)]))
Print Integer(fib.apply([Integer.Make(10)])).val


#include <stdio.h>
#include <stdlib.h>

/* func: our one and only data type; it holds either a pointer to
   a function call, or an integer.  Also carry a func pointer to
   a potential parameter, to simulate closure                   */
typedef struct func_t *func;
typedef struct func_t {
        func (*fn) (func, func);
        func _;
        int num;
} func_t;

func new(func(*f)(func, func), func _) {
        func x = malloc(sizeof(func_t));
        x->fn = f;
        x->_ = _;       /* closure, sort of */
        x->num = 0;
        return x;
}

func call(func f, func n) {
        return f->fn(f, n);
}

func Y(func(*f)(func, func)) {
        func g = new(f, 0);
        g->_ = g;
        return g;
}

func num(int n) {
        func x = new(0, 0);
        x->num = n;
        return x;
}

func fac(func self, func n) {
        int nn = n->num;
        return nn > 1   ? num(nn * call(self->_, num(nn - 1))->num)
                        : num(1);
}

func fib(func self, func n) {
        int nn = n->num;
        return nn > 1
                ? num(  call(self->_, num(nn - 1))->num +
                        call(self->_, num(nn - 2))->num )
                : num(1);
}

void show(func n) { printf(" %d", n->num); }

int main() {
        int i;
        func f = Y(fac);
        printf("fac: ");
        for (i = 1; i < 10; i++)
                show( call(f, num(i)) );
        printf("\n");

        f = Y(fib);
        printf("fib: ");
        for (i = 1; i < 10; i++)
                show( call(f, num(i)) );
        printf("\n");

        return 0;
}


using System;

static class YCombinator<T, TResult>
{
    // RecursiveFunc is not needed to call Fix() and so can be private.
    private delegate Func<T, TResult> RecursiveFunc(RecursiveFunc r);

    public static Func<Func<Func<T, TResult>, Func<T, TResult>>, Func<T, TResult>> Fix { get; } =
        f => ((RecursiveFunc)(g => f(x => g(g)(x))))(g => f(x => g(g)(x)));
}

static class Program
{
    static void Main()
    {
        var fac = YCombinator<int, int>.Fix(f => x => x < 2 ? 1 : x * f(x - 1));
        var fib = YCombinator<int, int>.Fix(f => x => x < 2 ? x : f(x - 1) + f(x - 2));

        Console.WriteLine(fac(10));
        Console.WriteLine(fib(10));
    }
}


Result(*Args) y1<Result,Args>(
        Result(*Args)(Result(*Args)) f)
        given Args satisfies Anything[] {

    class RecursiveFunction(o) {
        shared Result(*Args)(RecursiveFunction) o;
    }

    value r = RecursiveFunction((RecursiveFunction w)
        =>  f(flatten((Args args) => w.o(w)(*args))));

    return r.o(r);
}

value factorialY1 = y1((Integer(Integer) fact)(Integer x)
    =>  if (x > 1) then x * fact(x - 1) else 1);

value fibY1 = y1((Integer(Integer) fib)(Integer x)
    =>  if (x > 2) then fib(x - 1) + fib(x - 2) else 2);

print(factorialY1(10)); // 3628800
print(fibY1(10));       // 110


proc fixz(f) {
  record InnerFunc {
    const xi;
    proc this(a) { return xi(xi)(a); }
  }
  record XFunc {
    const fi;
    proc this(x) { return fi(new InnerFunc(x)); }
  }
  const g = new XFunc(f);
  return g(g);
}

record Facz {
  record FacFunc {
    const fi;
    proc this(n: int): int {
      return if n <= 1 then 1 else n * fi(n - 1); }
  }
  proc this(f) { return new FacFunc(f); }
}

record Fibz {
  record FibFunc {
    const fi;
    proc this(n: int): int {
      return if n <= 1 then n else fi(n - 2) + fi(n - 1); }
  }
  proc this(f) { return new FibFunc(f); }
}

const facz = fixz(new Facz());
const fibz = fixz(new Fibz());

writeln(facz(10));
writeln(fibz(10));


(defn Y [f]
  ((fn [x] (x x))
   (fn [x]
     (f (fn [& args]
          (apply (x x) args))))))

(def fac
     (fn [f]
       (fn [n]
         (if (zero? n) 1 (* n (f (dec n)))))))

(def fib
     (fn [f]
       (fn [n]
         (condp = n
           0 0
           1 1
           (+ (f (dec n))
              (f (dec (dec n))))))))


(defun Y (f)
  ((lambda (g) (funcall g g))
   (lambda (g)
     (funcall f (lambda (&rest a)
		  (apply (funcall g g) a))))))

(defun fac (n)
  (funcall
   (Y (lambda (f)
       (lambda (n)
         (if (zerop n)
	   1
	   (* n (funcall f (1- n)))))))
   n))

(defun fib (n)
  (funcall
   (Y (lambda (f)
       (lambda (n a b)
         (if (< n 1)
           a
           (funcall f (1- n) b (+ a b))))))
   n 0 1))

? (mapcar #'fac '(1 2 3 4 5 6 7 8 9 10))
(1 2 6 24 120 720 5040 40320 362880 3628800))

? (mapcar #'fib '(1 2 3 4 5 6 7 8 9 10))
(1 1 2 3 5 8 13 21 34 55)


require "big"

struct RecursiveFunc(T) # a generic recursive function wrapper...
  getter recfnc : RecursiveFunc(T) -> T
  def initialize(@recfnc) end
end

struct YCombo(T) # a struct or class needs to be used so as to be generic...
  def initialize (@fnc : Proc(T) -> T) end
  def fixy
    g = -> (x : RecursiveFunc(T)) {
              @fnc.call(-> { x.recfnc.call(x) }) }
    g.call(RecursiveFunc(T).new(g))
  end
end

def fac(x) # horrendouly inefficient not using tail calls...
  facp = -> (fn : Proc(BigInt -> BigInt)) {
               -> (n : BigInt) { n < 2 ? n : n * fn.call.call(n - 1) } }
  YCombo.new(facp).fixy.call(BigInt.new(x))
end

def fib(x) # horrendouly inefficient not using tail calls...
  facp = -> (fn : Proc(BigInt -> BigInt)) {
               -> (n : BigInt) {
                     n < 3 ? n - 1 : fn.call.call(n - 2) + fn.call.call(n - 1) } }
  YCombo.new(facp).fixy.call(BigInt.new(x))
end

puts fac(10)
puts fib(11) # starts from 0 not 1!


import std.stdio, std.traits, std.algorithm, std.range;

auto Y(S, T...)(S delegate(T) delegate(S delegate(T)) f) {
    static struct F {
        S delegate(T) delegate(F) f;
        alias f this;
    }
    return (x => x(x))(F(x => f((T v) => x(x)(v))));
}

void main() { // Demo code:
    auto factorial = Y((int delegate(int) self) =>
        (int n) => 0 == n ? 1 : n * self(n - 1)
    );

    auto ackermann = Y((ulong delegate(ulong, ulong) self) =>
        (ulong m, ulong n) {
            if (m == 0) return n + 1;
            if (n == 0) return self(m - 1, 1);
            return self(m - 1, self(m, n - 1));
    });

    writeln("factorial: ", 10.iota.map!factorial);
    writeln("ackermann(3, 5): ", ackermann(3, 5));
}


program Y;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type
  YCombinator = class sealed
    class function Fix<T> (F: TFunc<TFunc<T, T>, TFunc<T, T>>): TFunc<T, T>; static;
  end;

  TRecursiveFuncWrapper<T> = record // workaround required because of QC #101272 (http://qc.embarcadero.com/wc/qcmain.aspx?d=101272)
    type
      TRecursiveFunc = reference to function (R: TRecursiveFuncWrapper<T>): TFunc<T, T>;
    var
      O: TRecursiveFunc;
  end;

class function YCombinator.Fix<T> (F: TFunc<TFunc<T, T>, TFunc<T, T>>): TFunc<T, T>;
var
  R: TRecursiveFuncWrapper<T>;
begin
  R.O := function (W: TRecursiveFuncWrapper<T>): TFunc<T, T>
    begin
      Result := F (function (I: T): T
        begin
          Result := W.O (W) (I);
        end);
    end;
  Result := R.O (R);
end;

type
  IntFunc = TFunc<Integer, Integer>;

function AlmostFac (F: IntFunc): IntFunc;
begin
  Result := function (N: Integer): Integer
    begin
      if N <= 1 then
        Result := 1
      else
        Result := N * F (N - 1);
    end;
end;

function AlmostFib (F: TFunc<Integer, Integer>): TFunc<Integer, Integer>;
begin
  Result := function (N: Integer): Integer
    begin
      if N <= 2 then
        Result := 1
      else
        Result := F (N - 1) + F (N - 2);
    end;
end;

var
  Fib, Fac: IntFunc;
begin
  Fib := YCombinator.Fix<Integer> (AlmostFib);
  Fac := YCombinator.Fix<Integer> (AlmostFac);
  Writeln ('Fib(10) = ', Fib (10));
  Writeln ('Fac(10) = ', Fac (10));
end.


let const
    : ∀(b : Type) → ∀(a : Type) → a → b → a
    = λ(r : Type) → λ(a : Type) → λ(x : a) → λ(y : r) → x

let fac
    : ∀(n : Natural) → Natural
    = λ(n : Natural) →
        let factorial =
              λ(f : Natural → Natural → Natural) →
              λ(n : Natural) →
              λ(i : Natural) →
                if Natural/isZero i then n else f (i * n) (Natural/subtract 1 i)

        in  Natural/fold
              n
              (Natural → Natural → Natural)
              factorial
              (const Natural Natural)
              1
              n

let fib
    : ∀(n : Natural) → Natural
    = λ(n : Natural) →
        let fibFunc = Natural → Natural → Natural → Natural

        let fibonacci =
              λ(f : fibFunc) →
              λ(a : Natural) →
              λ(b : Natural) →
              λ(i : Natural) →
                if    Natural/isZero i
                then  a
                else  f b (a + b) (Natural/subtract 1 i)

        in  Natural/fold
              n
              fibFunc
              fibonacci
              (λ(a : Natural) → λ(_ : Natural) → λ(_ : Natural) → a)
              0
              1
              n

in [fac 50, fib 50]


Y f:
	labda y:
		labda:
			call y @y
		f
	labda x:
		x @x
	call

labda f:
	labda n:
		if < 1 n:
			* n f -- n
		else:
			1
set :fac Y

labda f:
	labda n:
		if < 1 n:
			+ f - n 2 f -- n
		else:
			1
set :fib Y

!. fac 6
!. fib 6


def y := fn f { fn x { x(x) }(fn y { f(fn a { y(y)(a) }) }) }
def fac := fn f { fn n { if (n<2) {1} else { n*f(n-1) } }}
def fib := fn f { fn n { if (n == 0) {0} else if (n == 1) {1} else { f(n-1) + f(n-2) } }}


;; Ref : http://www.ece.uc.edu/~franco/C511/html/Scheme/ycomb.html

 (define Y
    (lambda (X)
      ((lambda (procedure)
         (X (lambda (arg) ((procedure procedure) arg))))
       (lambda (procedure)
         (X (lambda (arg) ((procedure procedure) arg)))))))

; Fib
(define Fib* (lambda (func-arg)
    (lambda (n) (if (< n 2) n (+ (func-arg (- n 1)) (func-arg (- n 2)))))))
(define fib (Y Fib*))
(fib 6)
    → 8

; Fact
(define F*
   (lambda (func-arg) (lambda (n) (if (zero? n) 1 (* n (func-arg (- n 1)))))))
(define fact (Y F*))

(fact 10)
    → 3628800


#import <Foundation/Foundation.h>

typedef int (^Func)(int)
typedef Func (^FuncFunc)(Func)
typedef Func (^RecursiveFunc)(id) // hide recursive typing behind dynamic typing

Func fix(FuncFunc f)
  Func r(RecursiveFunc g)
    int s(int x)
      return g(g)(x)
    return f(s)
  return r(r)

int main(int argc, const char *argv[])
  autoreleasepool

    Func almost_fac(Func f)
      return (int n | return n <= 1 ? 1 : n * f(n - 1))

    Func almost_fib(Func f)
      return (int n | return n <= 2 ? 1 : f(n - 1) + f(n - 2))

    fib := fix(almost_fib)
    fac := fix(almost_fac)

    Log('fib(10) = %d', fib(10))
    Log('fac(10) = %d', fac(10))

  return 0


import extensions;

singleton YCombinator
{
    fix(func)
        = (f){(x){ x(x) }((g){ f((x){ (g(g))(x) })})}(func);
}

public program()
{
    var fib := YCombinator.fix:(f => (i => (i <= 1) ? i : (f(i-1) + f(i-2)) ));
    var fact := YCombinator.fix:(f => (i => (i == 0) ? 1 : (f(i-1) * i) ));

    console.printLine("fib(10)=",fib(10));
    console.printLine("fact(10)=",fact(10));
}


module Main exposing ( main )

import Html exposing ( Html, text )

-- As with most of the strict (non-deferred or non-lazy) languages,
-- this is the Z-combinator with the additional value parameter...

-- wrap type conversion to avoid recursive type definition...
type Mu a b = Roll (Mu a b -> a -> b)

unroll : Mu a b -> (Mu a b -> a -> b) -- unwrap it...
unroll (Roll x) = x

-- note lack of beta reduction using values...
fixz : ((a -> b) -> (a -> b)) -> (a -> b)
fixz f = let g r = f (\ v -> unroll r r v) in g (Roll g)

facz : Int -> Int
-- facz = fixz <| \ f n -> if n < 2 then 1 else n * f (n - 1) -- inefficient recursion
facz = fixz (\ f n i -> if i < 2 then n else f (i * n) (i - 1)) 1 -- efficient tailcall

fibz : Int -> Int
-- fibz = fixz <| \ f n -> if n < 2 then n else f (n - 1) + f (n - 2) -- inefficient recursion
fibz = fixz (\ fn f s i -> if i < 2 then f else fn s (f + s) (i - 1)) 1 1 -- efficient tailcall

-- by injecting laziness, we can get the true Y-combinator...
-- as this includes laziness, there is no need for the type wrapper!
fixy : ((() -> a) -> a) -> a
fixy f = f <| \ () -> fixy f -- direct function recursion
-- the above is not value recursion but function recursion!
-- fixv f = let x = f x in x -- not allowed by task or by Elm!
-- we can make Elm allow it by injecting laziness...
-- fixv f = let x = f () x in x -- but now value recursion not function recursion

facy : Int -> Int
-- facy = fixy <| \ f n -> if n < 2 then 1 else n * f () (n - 1) -- inefficient recursion
facy = fixy (\ f n i -> if i < 2 then n else f () (i * n) (i - 1)) 1 -- efficient tailcall

fiby : Int -> Int
-- fiby = fixy <| \ f n -> if n < 2 then n else f () (n - 1) + f (n - 2) -- inefficient recursion
fiby = fixy (\ fn f s i -> if i < 2 then f else fn () s (f + s) (i - 1)) 1 1 -- efficient tailcall

-- something that can be done with a true Y-Combinator that
-- can't be done with the Z combinator...
-- given an infinite Co-Inductive Stream (CIS) defined as...
type CIS a = CIS a (() -> CIS a) -- infinite lazy stream!

mapCIS : (a -> b) -> CIS a -> CIS b -- uses function to map
mapCIS cf cis =
  let mp (CIS head restf) = CIS (cf head) <| \ () -> mp (restf()) in mp cis

-- now we can define a Fibonacci stream as follows...
fibs : () -> CIS Int
fibs() = -- two recursive fix's, second already lazy...
  let fibsgen = fixy (\ fn (CIS (f, s) restf) ->
        CIS (s, f + s) (\ () -> fn () (restf())))
  in fixy (\ cisthnk -> fibsgen (CIS (0, 1) cisthnk))
       |> mapCIS (\ (v, _) -> v)

nCISs2String : Int -> CIS a -> String -- convert n CIS's to String
nCISs2String n cis =
  let loop i (CIS head restf) rslt =
        if i <= 0 then rslt ++ " )" else
        loop (i - 1) (restf()) (rslt ++ " " ++ Debug.toString head)
  in loop n cis "("

-- unfortunately, if we need CIS memoization so as
-- to make a true lazy list, Elm doesn't support it!!!

main : Html Never
main =
  String.fromInt (facz 10) ++ " " ++ String.fromInt (fibz 10)
    ++ " " ++ String.fromInt (facy 10) ++ " " ++ String.fromInt (fiby 10)
    ++ " " ++ nCISs2String 20 (fibs())
      |> text


type 'a mu = Roll of ('a mu -> 'a)  // ' fixes ease syntax colouring confusion with

let unroll (Roll x) = x
// val unroll : 'a mu -> ('a mu -> 'a)

// As with most of the strict (non-deferred or non-lazy) languages,
// this is the Z-combinator with the additional 'a' parameter...
let fix f = let g = fun x a -> f (unroll x x) a in g (Roll g)
// val fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b = <fun>

// Although true to the factorial definition, the
// recursive call is not in tail call position, so can't be optimized
// and will overflow the call stack for the recursive calls for large ranges...
//let fac = fix (fun f n -> if n < 2 then 1I else bigint n * f (n - 1))
// val fac : (int -> BigInteger) = <fun>

// much better progressive calculation in tail call position...
let fac = fix (fun f n i -> if i < 2 then n else f (bigint i * n) (i - 1)) <| 1I
// val fac : (int -> BigInteger) = <fun>

// Although true to the definition of Fibonacci numbers,
// this can't be tail call optimized and recursively repeats calculations
// for a horrendously inefficient exponential performance fib function...
// let fib = fix (fun fnc n -> if n < 2 then n else fnc (n - 1) + fnc (n - 2))
// val fib : (int -> BigInteger) = <fun>

// much better progressive calculation in tail call position...
let fib = fix (fun fnc f s i -> if i < 2 then f else fnc s (f + s) (i - 1)) 1I 1I
// val fib : (int -> BigInteger) = <fun>

[<EntryPoint>]
let main argv =
  fac 10 |> printfn "%A" // prints 3628800
  fib 10 |> printfn "%A" // prints 55
  0 // return an integer exit code


USING: fry kernel math ;
IN: rosettacode.Y
: Y ( quot -- quot )
    '[ [ dup call call ] curry @ ] dup call ; inline

: almost-fac ( quot -- quot )
    '[ dup zero? [ drop 1 ] [ dup 1 - @ * ] if ] ;

: almost-fib ( quot -- quot )
    '[ dup 2 >= [ 1 2 [ - @ ] [email protected] bi + ] when ] ;


\ Address of an xt.
variable 'xt
\ Make room for an xt.
: xt, ( -- ) here 'xt !  1 cells allot ;
\ Store xt.
: !xt ( xt -- ) 'xt @ ! ;
\ Compile fetching the xt.
: @xt, ( -- ) 'xt @ postpone literal postpone @ ;
\ Compile the Y combinator.
: y, ( xt1 -- xt2 ) >r :noname @xt, r> compile, postpone ; ;
\ Make a new instance of the Y combinator.
: y ( xt1 -- xt2 ) xt, y, dup !xt ;


Function Y(f As String) As String
    Y = f
End Function

Function fib(n As Long) As Long
    Dim As Long n1 = 0, n2 = 1, k, sum
    For k = 1 To Abs(n)
        sum = n1 + n2
        n1 = n2
        n2 = sum
    Next k
    Return Iif(n < 0, (n1 * ((-1) ^ ((-n)+1))), n1)
End Function

Function fac(n As Long) As Long
    Dim As Long r = 1, i
    For i = 2 To n
        r *= i
    Next i
    Return r
End Function

Function execute(s As String, n As Integer) As Long
    Return Iif (s = "fac", fac(n), fib(n))
End Function

Sub test(nombre As String)
    Dim f As String: f = Y(nombre)
    Print !"\n"; f; ":";
    For i As Integer = 1 To 10
        Print execute(f, i);
    Next i
End Sub

test("fac")
test("fib")
Sleep


Y := function(f)
    local u;
    u := x -> x(x);
    return u(y -> f(a -> y(y)(a)));
end;

fib := function(f)
    local u;
    u := function(n)
        if n < 2 then
            return n;
        else
            return f(n-1) + f(n-2);
        fi;
    end;
    return u;
end;

Y(fib)(10);
# 55

fac := function(f)
    local u;
    u := function(n)
        if n < 2 then
            return 1;
        else
            return n*f(n-1);
        fi;
    end;
    return u;
end;

Y(fac)(8);
# 40320


def fac (f)
    function (n)
      if (equal? n 0) 1
        * n (f (- n 1))
def fib (f)
  function (n)
    cond
      (equal? n 0) 0
      (equal? n 1) 1
      else (+ (f (- n 1)) (f (- n 2)))

def Y (f)
  (function (x) (x x))
      function (y)
          f
             function (&rest args) (apply (y y) args)

assertEqual ((Y fac) 5) 120
assertEqual ((Y fib) 8) 21


package main

import "fmt"

type Func func(int) int
type FuncFunc func(Func) Func
type RecursiveFunc func (RecursiveFunc) Func

func main() {
	fac := Y(almost_fac)
	fib := Y(almost_fib)
	fmt.Println("fac(10) = ", fac(10))
	fmt.Println("fib(10) = ", fib(10))
}

func Y(f FuncFunc) Func {
	g := func(r RecursiveFunc) Func {
		return f(func(x int) int {
			return r(r)(x)
		})
	}
	return g(g)
}

func almost_fac(f Func) Func {
	return func(x int) int {
		if x <= 1 {
			return 1
		}
		return x * f(x-1)
	}
}

func almost_fib(f Func) Func {
	return func(x int) int {
		if x <= 2 {
			return 1
		}
		return f(x-1)+f(x-2)
	}
}


newtype Mu a = Roll
  { unroll :: Mu a -> a }

fix :: (a -> a) -> a
fix = g <*> (Roll . g)
  where
    g = (. (>>= id) unroll)

- this version is not in tail call position...
-- fac :: Integer -> Integer
-- fac =
--   fix $ \f n -> if n <= 0 then 1 else n * f (n - 1)

-- this version builds a progression from tail call position and is more efficient...
fac :: Integer -> Integer
fac =
  (fix $ \f n i -> if i <= 0 then n else f (i * n) (i - 1)) 1

-- make fibs a function, else memory leak as
-- head of the list can never be released as per:
--   https://wiki.haskell.org/Memory_leak, type 1.1
-- overly complex version...
{--
fibs :: () -> [Integer]
fibs() =
  fix $
    (0 :) . (1 :) .
      (fix
        (\f (x:xs) (y:ys) ->
          case x + y of n -> n `seq` n : f xs ys) <*> tail)
--}

-- easier to read, simpler (faster) version...
fibs :: () -> [Integer]
fibs() = 0 : 1 : fix fibs_ 0 1
  where
    fibs_ fnc f s =
      case f + s of n -> n `seq` n : fnc s n

main :: IO ()
main =
  mapM_
    print
    [ map fac [1 .. 20]
    , take 20 $ fibs()
    ]


import java.util.function.Function;

public interface YCombinator {
  interface RecursiveFunction<F> extends Function<RecursiveFunction<F>, F> { }
  public static <A,B> Function<A,B> Y(Function<Function<A,B>, Function<A,B>> f) {
    RecursiveFunction<Function<A,B>> r = w -> f.apply(x -> w.apply(w).apply(x));
    return r.apply(r);
  }

  public static void main(String... arguments) {
    Function<Integer,Integer> fib = Y(f -> n ->
      (n <= 2)
        ? 1
        : (f.apply(n - 1) + f.apply(n - 2))
    );
    Function<Integer,Integer> fac = Y(f -> n ->
      (n <= 1)
        ? 1
        : (n * f.apply(n - 1))
    );

    System.out.println("fib(10) = " + fib.apply(10));
    System.out.println("fac(10) = " + fac.apply(10));
  }
}


function Y(f) {
    var g = f((function(h) {
        return function() {
            var g = f(h(h));
            return g.apply(this, arguments);
        }
    })(function(h) {
        return function() {
            var g = f(h(h));
            return g.apply(this, arguments);
        }
    }));
    return g;
}

var fac = Y(function(f) {
    return function (n) {
        return n > 1 ? n * f(n - 1) : 1;
    };
});

var fib = Y(function(f) {
    return function(n) {
        return n > 1 ? f(n - 1) + f(n - 2) : n;
    };
});


DEFINE y == [dup cons] swap concat dup cons i;

     fac == [ [pop null] [pop succ] [[dup pred] dip i *] ifte ] y.


:fac
    dup 1 great [dup 1 sub fac mult] if
;

:fib
    dup 1 great [dup 1 sub fib swap 2 sub fib add] if
;

:test
    print ": " print
    10 [over exec print " " print] for
    nl
;

@fib "fib" test
@fac "fac" test

"End " input


// version 1.1.2

typealias Func<T, R> = (T) -> R

class RecursiveFunc<T, R>(val p: (RecursiveFunc<T, R>) -> Func<T, R>)

fun <T, R> y(f: (Func<T, R>) -> Func<T, R>): Func<T, R> {
    val rec = RecursiveFunc<T, R> { r -> f { r.p(r)(it) } }
    return rec.p(rec)
}

fun fac(f: Func<Int, Int>) = { x: Int -> if (x <= 1) 1 else x * f(x - 1) }

fun fib(f: Func<Int, Int>) = { x: Int -> if (x <= 2) 1 else f(x - 1) + f(x - 2) }

fun main(args: Array<String>) {
    print("Factorial(1..10)   : ")
    for (i in 1..10) print("${y(::fac)(i)}  ")
    print("\nFibonacci(1..10)   : ")
    for (i in 1..10) print("${y(::fib)(i)}  ")
    println()
}


1) defining the Ycombinator
{def Y {lambda {:f} {:f :f}}}

2) defining non recursive functions
2.1) factorial
{def almost-fac
 {lambda {:f :n}
  {if {= :n 1}
   then 1
   else {* :n {:f :f {- :n 1}}}}}}

2.2) fibonacci
{def almost-fibo
 {lambda {:f :n}
  {if {<   :n 2}
   then 1
   else {+ {:f :f {- :n 1}} {:f :f {- :n 2}}}}}}

3) testing
{{Y almost-fac} 6}
-> 720
{{Y almost-fibo} 8}
-> 34


Y = function (f)
   return function(...)
      return (function(x) return x(x) end)(function(x) return f(function(y) return x(x)(y) end) end)(...)
   end
end


Module Ycombinator {
	\\ y() return value. no use of closure
	y=lambda (g, x)->g(g, x)
	Print y(lambda (g, n as decimal)->if(n=0->1, n*g(g, n-1)), 10)=3628800 ' true
	Print y(lambda (g, n)->if(n<=1->n,g(g, n-1)+g(g, n-2)), 10)=55 ' true

	\\ Using closure in y, y() return function
	y=lambda (g)->lambda g (x) -> g(g, x)
	fact=y((lambda (g, n as decimal)-> if(n=0->1, n*g(g, n-1))))
	Print fact(6)=720, fact(24)[email protected]
	fib=y(lambda (g, n)->if(n<=1->n, g(g, n-1)+g(g, n-2)))
	Print  fib(10)=55
	}
Ycombinator


{ {extern "manool.org.18/std/0.3/all"} in
: let { Y = {proc {F} as {proc {X} as X[X]}[{proc {X} with {F} as F[{proc {Y} with {X} as X[X][Y]}]}]} } in
  { for { N = Range[10] } do
  : (WriteLine) Out; N "! = "
    {Y: proc {Rec} as {proc {N} with {Rec} as: if N == 0 then 1 else N * Rec[N - 1]}}$[N]
  }
  { for { N = Range[10] } do
  : (WriteLine) Out; "Fib " N " = "
    {Y: proc {Rec} as {proc {N} with {Rec} as: if N == 0 then 0 else: if N == 1 then 1 else Rec[N - 2] + Rec[N - 1]}}$[N]
  }
}


Z = (f using nil) -> ((x) -> x x) (x) -> f (...) -> (x x) ...
factorial = Z (f using nil) -> (n) -> if n == 0 then 1 else n * f n - 1


# The following is implemented for a strict language as a Z-Combinator;
# Z-combinators differ from Y-combinators in lacking one Beta reduction of
# the extra `T` argument to the function to be recursed...

import sugar

proc fixz[T, TResult](f: ((T) -> TResult) -> ((T) -> TResult)): (T) -> TResult =
  type RecursiveFunc = object # any entity that wraps the recursion!
    recfnc: ((RecursiveFunc) -> ((T) -> TResult))
  let g = (x: RecursiveFunc) => f ((a: T) => x.recfnc(x)(a))
  g(RecursiveFunc(recfnc: g))

let facz = fixz((f: (int) -> int) =>
  ((n: int) => (if n <= 1: 1 else: n * f(n - 1))))
let fibz = fixz((f: (int) -> int) =>
  ((n: int) => (if n < 2: n else: f(n - 2) + f(n - 1))))

echo facz(10)
echo fibz(10)

# by adding some laziness, we can get a true Y-Combinator...
# note that there is no specified parmater(s) - truly fix point!...

#[
proc fixy[T](f: () -> T -> T): T =
  type RecursiveFunc = object # any entity that wraps the recursion!
    recfnc: ((RecursiveFunc) -> T)
  let g = ((x: RecursiveFunc) => f(() => x.recfnc(x)))
  g(RecursiveFunc(recfnc: g))
# ]#

# same thing using direct recursion as Nim has...
# note that this version of fix uses function recursion in its own definition;
# thus its use just means that the recursion has been "pulled" into the "fix" function,
# instead of the function that uses it...
proc fixy[T](f: () -> T -> T): T = f(() => (fixy(f)))

# these are dreadfully inefficient as they becursively build stack!...
let facy = fixy((f: () -> (int -> int)) =>
  ((n: int) => (if n <= 1: 1 else: n * f()(n - 1))))

let fiby = fixy((f: () -> (int -> int)) =>
  ((n: int) => (if n < 2: n else: f()(n - 2) + f()(n - 1))))

echo facy 10
echo fiby 10

# something that can be done with the Y-Combinator that con't be done with the Z...
# given the following Co-Inductive Stream (CIS) definition...
type CIS[T] = object
  head: T
  tail: () -> CIS[T]

# Using a double Y-Combinator recursion...
# defines a continuous stream of Fibonacci numbers; there are other simpler ways,
# this way implements recursion by using the Y-combinator, although it is
# much slower than other ways due to the many additional function calls,
# it demonstrates something that can't be done with the Z-combinator...
iterator fibsy: int {.closure.} = # two recursions...
  let fbsfnc: (CIS[(int, int)] -> CIS[(int, int)]) = # first one...
    fixy((fnc: () -> (CIS[(int,int)] -> CIS[(int,int)])) =>
      ((cis: CIS[(int,int)]) => (
        let (f,s) = cis.head;
        CIS[(int,int)](head: (s, f + s), tail: () => fnc()(cis.tail())))))
  var fbsgen: CIS[(int, int)] = # second recursion
    fixy((cis: () -> CIS[(int,int)]) => # cis is a lazy thunk used directly below!
      fbsfnc(CIS[(int,int)](head: (1,0), tail: cis)))
  while true: yield fbsgen.head[0]; fbsgen = fbsgen.tail()

let fibs = fibsy
for _ in 1 .. 20: stdout.write fibs(), " "
echo()


#import <Foundation/Foundation.h>

typedef int (^Func)(int);
typedef Func (^FuncFunc)(Func);
typedef Func (^RecursiveFunc)(id); // hide recursive typing behind dynamic typing

Func Y(FuncFunc f) {
  RecursiveFunc r =
  ^(id y) {
    RecursiveFunc w = y; // cast value back into desired type
    return f(^(int x) {
      return w(w)(x);
    });
  };
  return r(r);
}

int main (int argc, const char *argv[]) {
  @autoreleasepool {

    Func fib = Y(^Func(Func f) {
      return ^(int n) {
        if (n <= 2) return 1;
        return  f(n - 1) + f(n - 2);
      };
    });
    Func fac = Y(^Func(Func f) {
      return ^(int n) {
        if (n <= 1) return 1;
        return n * f(n - 1);
      };
    });

    Func fib = fix(almost_fib);
    Func fac = fix(almost_fac);
    NSLog(@"fib(10) = %d", fib(10));
    NSLog(@"fac(10) = %d", fac(10));

  }
  return 0;
}


let fix f g = (fun x a -> f (x x) a) (fun x a -> f (x x) a) g


#include <order/interpreter.h>

#define ORDER_PP_DEF_8y                                             \
ORDER_PP_FN(8fn(8F,                                                 \
            8let((8R, 8fn(8G,                                       \
                          8ap(8F, 8fn(8A, 8ap(8ap(8G, 8G), 8A))))), \
                 8ap(8R, 8R))))

#define ORDER_PP_DEF_8fac \
ORDER_PP_FN(8fn(8F, 8X,   \
                8if(8less_eq(8X, 0), 1, 8times(8X, 8ap(8F, 8minus(8X, 1))))))

#define ORDER_PP_DEF_8fib                                           \
ORDER_PP_FN(8fn(8F, 8X,                                             \
                8if(8less(8X, 2), 8X, 8plus(8ap(8F, 8minus(8X, 1)), \
                                            8ap(8F, 8minus(8X, 2))))))

ORDER_PP(8to_lit(8ap(8y(8fac), 10)))    // 3628800
ORDER_PP(8ap(8y(8fib), 10))             // 55


declare
  Y = fun {$ F}
         {fun {$ X} {X X} end
          fun {$ X} {F fun {$ Z} {{X X} Z} end} end}
      end

  Fac = {Y fun {$ F}
              fun {$ N}
                 if N == 0 then 1 else N*{F N-1} end
              end
           end}

  Fib = {Y fun {$ F}
              fun {$ N}
                 case N of 0 then 0
                 [] 1 then 1
                 else {F N-1} + {F N-2}
                 end
              end
           end}
in
  {Show {Fac 5}}
  {Show {Fib 8}}


with javascript_semantics
function call_fn(integer f, n)
    return call_func(f,{f,n})
end function

function Y(integer f)
    return f
end function

function fac(integer self, integer n)
    return iff(n>1?n*call_fn(self,n-1):1)
end function

function fib(integer self, integer n)
    return iff(n>1?call_fn(self,n-1)+call_fn(self,n-2):n)
end function

procedure test(string name, integer rid=routine_id(name))
    integer f = Y(rid)
    printf(1,"%s: ",{name})
    for i=1 to 10 do
        printf(1," %d",call_fn(f,i))
    end for
    printf(1,"\n");
end procedure
test("fac")
test("fib")


0 var subr

def fac
    dup 1 > if
        dup 1 - subr exec *
    endif
enddef

def fib
    dup 1 > if
        dup 1 - subr exec swap 2 - subr exec +
    endif
enddef

def test
    print ": " print
    var subr
    10 for
        subr exec print " " print
    endfor
    nl
enddef

getid fac "fac" test
getid fib "fib" test


<?php
function Y($f) {
  $g = function($w) use($f) {
    return $f(function() use($w) {
      return call_user_func_array($w($w), func_get_args());
    });
  };
  return $g($g);
}

$fibonacci = Y(function($f) {
  return function($i) use($f) { return ($i <= 1) ? $i : ($f($i-1) + $f($i-2)); };
});

echo $fibonacci(10), "\n";

$factorial = Y(function($f) {
  return function($i) use($f) { return ($i <= 1) ? 1 : ($f($i - 1) * $i); };
});

echo $factorial(10), "\n";
?>


(de Y (F)
   (let X (curry (F) (Y) (F (curry (Y) @ (pass (Y Y)))))
      (X X) ) )


define Y(f);
    procedure (x); x(x) endprocedure(
        procedure (y);
            f(procedure(z); (y(y))(z) endprocedure)
        endprocedure
    )
enddefine;

define fac(h);
    procedure (n);
       if n = 0 then 1 else n * h(n - 1) endif
    endprocedure
enddefine;

define fib(h);
    procedure (n);
        if n < 2 then 1 else h(n - 1) + h(n - 2) endif
    endprocedure
enddefine;

Y(fac)(5) =>
Y(fib)(5) =>


y {
    {dup cons} exch concat dup cons i
}.

/fac {
    { {pop zero?} {pop succ} {{dup pred} dip i *} ifte }
    y
}.


$fac = {
    	param([ScriptBlock] $f)
    	invoke-expression @"
    	{
    		param([int] `$n)
    		if (`$n -le 0) {1}
    		else {`$n * {$f}.InvokeReturnAsIs(`$n - 1)}
    	}
"@
    }

$fib = {
	param([ScriptBlock] $f)
	invoke-expression @"
	{
		param([int] `$n)
		switch (`$n)
        {
        0 {1}
        1 {1}
        default {{$f}.InvokeReturnAsIs(`$n-1)+{$f}.InvokeReturnAsIs(`$n-2)}
        }
	}
"@
}

$Z = {
    param([ScriptBlock] $f)
    invoke-expression @"
    {
        param([ScriptBlock] `$x)
        {$f}.InvokeReturnAsIs(`$(invoke-expression @`"
        {
            param(```$y)
            {`$x}.InvokeReturnAsIs({`$x}).InvokeReturnAsIs(```$y)
        }
`"@))
    }.InvokeReturnAsIs({
        param([ScriptBlock] `$x)
        {$f}.InvokeReturnAsIs(`$(invoke-expression @`"
        {
            param(```$y)
            {`$x}.InvokeReturnAsIs({`$x}).InvokeReturnAsIs(```$y)
        }
`"@))
    })
"@
}

$Z.InvokeReturnAsIs($fac).InvokeReturnAsIs(5)
$Z.InvokeReturnAsIs($fib).InvokeReturnAsIs(5)


:- use_module(lambda).

% The Y combinator
y(P, Arg, R) :-
	Pred = P +\Nb2^F2^call(P,Nb2,F2,P),
	call(Pred, Arg, R).

test_y_combinator :-
    % code for Fibonacci function
    Fib   = \NFib^RFib^RFibr1^(NFib < 2 ->
			         RFib = NFib
			      ;
			         NFib1 is NFib - 1,
			         NFib2 is NFib - 2,
			         call(RFibr1,NFib1,RFib1,RFibr1),
			         call(RFibr1,NFib2,RFib2,RFibr1),
			         RFib is RFib1 + RFib2
			      ),

    y(Fib, 10, FR), format('Fib(~w) = ~w~n', [10, FR]),

    % code for Factorial function
    Fact =  \NFact^RFact^RFactr1^(NFact = 1 ->
			            RFact = NFact
                                 ;
			            NFact1 is NFact - 1,
			            call(RFactr1,NFact1,RFact1,RFactr1),
			            RFact is NFact * RFact1
			         ),

    y(Fact, 10, FF), format('Fact(~w) = ~w~n', [10, FF]).


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program outputXml64.s   */
/* use special library libxml2   */
/* special link gcc with options -I/usr/include/libxml2 -lxml2 */

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

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessEndpgm:      .asciz "Normal end of program.\n"
szFileName:        .asciz "file2.xml"
szFileMode:        .asciz "w"
szMessError:       .asciz "Error detected !!!!. \n"
szName1:           .asciz "April"
szName2:           .asciz "Tam O'Shanter"
szName3:           .asciz "Emily"
szRemark1:         .asciz "Bubbly: I'm > Tam and <= Emily"
szRemark2:         .asciz "Burns: \"When chapman billies leave the street ...\""
szRemark3:         .asciz "Short & shrift"
szVersDoc:         .asciz "1.0"
szLibCharRem:      .asciz "CharacterRemarks"
szLibChar:         .asciz "Character"

szLibName:         .asciz "Name"
szCarriageReturn:  .asciz "\n"

tbNames:           .quad szName1              // area of pointer string name
                   .quad szName2
                   .quad szName3
                   .quad 0                    // area end
tbRemarks:         .quad szRemark1            // area of pointer string remark
                   .quad szRemark2
                   .quad szRemark3
                   .quad 0                    // area end
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
.align 4

/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                     // entry of program
    ldr x0,qAdrszVersDoc
    bl xmlNewDoc                          // create doc
    mov x19,x0                            // doc address
    mov x0,#0
    ldr x1,qAdrszLibCharRem
    bl xmlNewNode                         // create root node
    mov x20,x0                            // node characterisation address
    mov x0,x19                            // doc
    mov x1,x20                            // node root
    bl xmlDocSetRootElement
    ldr x22,qAdrtbNames
    ldr x23,qAdrtbRemarks
    mov x24,#0                            // loop counter
1:                                        // start loop
    mov x0,#0
    ldr x1,qAdrszLibChar                  // create node
    bl xmlNewNode
    mov x21,x0                            // node character
                                          // x0 = node address
    ldr x1,qAdrszLibName
    ldr x2,[x22,x24,lsl #3]               // load name string address
    bl xmlNewProp
    ldr x0,[x23,x24,lsl #3]               // load remark string address
    bl xmlNewText
    mov x1,x0
    mov x0,x21
    bl xmlAddChild
    mov x0,x20
    mov x1,x21
    bl xmlAddChild
    add x24,x24,#1
    ldr x2,[x22,x24,lsl #3]                // load name string address
    cmp x2,#0                              // = zero ?
    bne 1b                                 // no -> loop

    ldr x0,qAdrszFileName
    ldr x1,qAdrszFileMode
    bl fopen                               // file open
    cmp x0,#0
    blt 99f
    mov x24,x0                              //FD
    mov x1,x19
    mov x2,x20
    bl xmlDocDump                          // write doc on the file

    mov x0,x24                             // close file
    bl fclose
    mov x0,x19                             // close document
    bl xmlFreeDoc
    bl xmlCleanupParser
    ldr x0,qAdrszMessEndpgm
    bl affichageMess
    b 100f
99:                                        // error
    ldr x0,qAdrszMessError
    bl affichageMess
100:                                       // standard end of the program
    mov x0,0                               // return code
    mov x8,EXIT                            // request to exit program
    svc 0                                  // perform the system call

qAdrszMessError:          .quad szMessError
qAdrszMessEndpgm:         .quad szMessEndpgm
qAdrszVersDoc:            .quad szVersDoc
qAdrszLibCharRem:         .quad szLibCharRem
qAdrszLibChar:            .quad szLibChar
qAdrszLibName:            .quad szLibName
qAdrtbNames:              .quad tbNames
qAdrtbRemarks:            .quad tbRemarks
qAdrszCarriageReturn:     .quad szCarriageReturn
qStdout:                  .quad STDOUT
qAdrszFileName:           .quad szFileName
qAdrszFileMode:           .quad szFileMode

/************************************/
/* Strings comparaison              */
/************************************/
/* x0 et x1 contains strings addresses */
/* x0 return 0 dans x0 if equal */
/* return -1 if string x0 < string x1 */
/* return 1  if string x0 > string x1 */
comparString:
    stp x2,lr,[sp,-16]!            // save  registers
    stp x3,x4,[sp,-16]!            // save  registers
    mov x2,#0                   // indice
1:
    ldrb w3,[x0,x2]             // one byte string 1
    ldrb w4,[x1,x2]             // one byte string 2
    cmp w3,w4
    blt 2f                      // less
    bgt 3f                      // greather
    cmp w3,#0                   // 0 final
    beq 4f                      // equal and end
    add x2,x2,#1                //
    b 1b                        // else loop
2:
    mov x0,#-1                  // less
    b 100f
3:
    mov x0,#1                   // greather
    b 100f
4:
    mov x0,#0                   // equal
    b 100f
100:
    ldp x3,x4,[sp],16           // restaur  2 registers
    ldp x2,lr,[sp],16           // restaur  2 registers
    ret                         // return to address lr x30

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


DEFINE PTR="CARD"
DEFINE CHARACTER_SIZE="4"
TYPE Character=[PTR name,remark]

PTR FUNC GetCharacterPointer(BYTE ARRAY d INT index)
RETURN (d+index*CHARACTER_SIZE)

PROC SetCharacter(BYTE ARRAY d INT index CHAR ARRAY n,r)
  Character POINTER ch

  ch=GetCharacterPointer(d,index)
  ch.name=n
  ch.remark=r
RETURN

PROC PrintEscaped(CHAR ARRAY s)
  INT i
  CHAR c

  FOR i=1 TO s(0)
  DO
    c=s(i)
    IF c='< THEN
      Print("<")
    ELSEIF c='> THEN
      Print(">")
    ELSEIF c='& THEN
      Print("&")
    ELSE
      Put(c)
    FI
  OD
RETURN

PROC OutputNode(CHAR ARRAY node,tagName,tagValue BYTE closing)
  Put('<)
  IF closing THEN Put('/) FI
  Print(node)
  IF tagName(0)>0 THEN
    PrintF(" %S=""",tagName)
    PrintEscaped(tagValue) Put('")
  FI
  Put('>)
RETURN

PROC OutputCharacter(Character POINTER ch)
  CHAR ARRAY node="Character"

  OutputNode(node,"name",ch.name,0)
  PrintEscaped(ch.remark)
  OutputNode(node,"","",1)
RETURN

PROC OutputCharacters(BYTE ARRAY d INT count)
  CHAR ARRAY node="CharacterRemarks"
  Character POINTER ch
  INT i

  OutputNode(node,"","",0) PutE()
  FOR i=0 TO count-1
  DO
    ch=GetCharacterPointer(d,i)
    OutputCharacter(ch) PutE()
  OD
  OutputNode(node,"","",1) PutE()
RETURN

PROC Main()
  BYTE count=[3]
  BYTE ARRAY d(12)

  SetCharacter(d,0,"April","Bubbly: I'm > Tam and <= Emily")
  SetCharacter(d,1,"Tam O'Shanter","Burns: ""When chapman billies leave the street ...""")
  SetCharacter(d,2,"Emily","Short & shrift")

  OutputCharacters(d,count)
RETURN


with Ada.Strings.Unbounded;
with Ada.Text_IO.Text_Streams;
with DOM.Core.Documents;
with DOM.Core.Elements;
with DOM.Core.Nodes;

procedure Character_Remarks is
   package DC renames DOM.Core;
   package IO renames Ada.Text_IO;
   package US renames Ada.Strings.Unbounded;
   type Remarks is record
      Name : US.Unbounded_String;
      Text : US.Unbounded_String;
   end record;
   type Remark_List is array (Positive range <>) of Remarks;
   My_Remarks : Remark_List :=
      ((US.To_Unbounded_String ("April"),
        US.To_Unbounded_String ("Bubbly: I'm > Tam and <= Emily")),
       (US.To_Unbounded_String ("Tam O'Shanter"),
        US.To_Unbounded_String ("Burns: ""When chapman billies leave the street ...""")),
       (US.To_Unbounded_String ("Emily"),
        US.To_Unbounded_String ("Short & shrift")));
   My_Implementation : DC.DOM_Implementation;
   My_Document       : DC.Document := DC.Create_Document (My_Implementation);
   My_Root_Node      : DC.Element  := DC.Nodes.Append_Child (My_Document,
                                         DC.Documents.Create_Element (My_Document, "CharacterRemarks"));
   My_Element_Node   : DC.Element;
   My_Text_Node      : DC.Text;
begin
   for I in My_Remarks'Range loop
      My_Element_Node := DC.Nodes.Append_Child (My_Root_Node,
                            DC.Documents.Create_Element (My_Document, "Character"));
      DC.Elements.Set_Attribute (My_Element_Node, "Name", US.To_String (My_Remarks (I).Name));
      My_Text_Node    := DC.Nodes.Append_Child (My_Element_Node,
                            DC.Documents.Create_Text_Node (My_Document, US.To_String (My_Remarks (I).Text)));
   end loop;
   DC.Nodes.Write (IO.Text_Streams.Stream (IO.Standard_Output),
                   N => My_Document,
                   Pretty_Print => True);
end Character_Remarks;


  [ ' stack nested nested
    ' share nested join
    swap nested join
    dup dup 0 peek put ]   is recursive (   x --> x )

  [ over 2 < iff
      [ 2drop 1 ] done
    dip [ dup 1 - ] do * ] is factorial ( n x --> n )

  [ over 2 < iff drop done
    swap 1 - tuck 1 -
    over do dip do + ]     is fibonacci ( n x --> n )

  say "8 factorial = " 8 ' factorial recursive do echo cr
  say "8 fibonacci = " 8 ' fibonacci recursive do echo cr


Y <- function(f) {
  (function(x) { (x)(x) })( function(y) { f( (function(a) {y(y)})(a) ) } )
}


#lang lazy

(define Y (λ (f) ((λ (x) (f (x x))) (λ (x) (f (x x))))))

(define Fact
  (Y (λ (fact) (λ (n) (if (zero? n) 1 (* n (fact (- n 1))))))))
(define Fib
  (Y (λ (fib) (λ (n) (if (<= n 1) n (+ (fib (- n 1)) (fib (- n 2))))))))


# returns a translation of str suitable for attribute values and content in an XML document #
OP  TOXMLSTRING = ( STRING str )STRING:
    BEGIN
        STRING result := "";
        FOR pos FROM LWB str TO UPB str DO
            CHAR c = str[ pos ];
            result +:= IF   c = "<"   THEN "<"
                       ELIF c = ">"   THEN ">"
                       ELIF c = "&"   THEN "&"
                       ELIF c = "'"   THEN "'"
                       ELIF c = """"  THEN """
                       ELSE c
                       FI
        OD;
        result
    END; # TOXMLSTRING #

# generate a CharacterRemarks XML document from the characters and remarks #
# the number of elements in characters and remrks must be equal - this is not checked #
# the <?xml?> element is not generated #
PROC generate character remarks document = ( []STRING characters, remarks )STRING:
     BEGIN
         STRING result     := "<CharacterRemarks>";
         INT    remark pos := LWB remarks;
         FOR char pos FROM LWB characters TO UPB characters DO
             result +:= "<Character name=""" + TOXMLSTRING characters[ char pos ] + """>"
                      + TOXMLSTRING remarks[ remark pos ]
                      + "</Character>"
                      + REPR 10
                      ;
             remark pos +:= 1
         OD;
         result +:= "</CharacterRemarks>";
         result
     END; # generate character remarks document #

# test the generation #
print( ( generate character remarks document( ( "April", "Tam O'Shanter", "Emily" )
                                            , ( "Bubbly: I'm > Tam and <= Emily"
                                              , "Burns: ""When chapman billies leave the street ..."
                                              , "Short & shrift"
                                              )
                                            )
        , newline
        )
      )


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

/* Constantes    */
.equ STDOUT, 1     @ Linux output console
.equ EXIT,   1     @ Linux syscall
.equ WRITE,  4     @ Linux syscall

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessEndpgm:      .asciz "Normal end of program.\n"
szFileName:        .asciz "file2.xml"
szFileMode:        .asciz "w"
szMessError:       .asciz "Error detected !!!!. \n"
szName1:           .asciz "April"
szName2:           .asciz "Tam O'Shanter"
szName3:           .asciz "Emily"
szRemark1:         .asciz "Bubbly: I'm > Tam and <= Emily"
szRemark2:         .asciz "Burns: \"When chapman billies leave the street ...\""
szRemark3:         .asciz "Short & shrift"
szVersDoc:         .asciz "1.0"
szLibCharRem:      .asciz "CharacterRemarks"
szLibChar:         .asciz "Character"

//szLibExtract:    .asciz "Student"
szLibName:         .asciz "Name"
szCarriageReturn:  .asciz "\n"

tbNames:           .int szName1              @ area of pointer string name
                   .int szName2
                   .int szName3
                   .int 0                    @ area end
tbRemarks:         .int szRemark1            @ area of pointer string remark
                   .int szRemark2
                   .int szRemark3
                   .int 0                    @ area end
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
.align 4

/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                     @ entry of program
    ldr r0,iAdrszVersDoc
    bl xmlNewDoc                          @ create doc
    mov r9,r0                             @ doc address
    mov r0,#0
    ldr r1,iAdrszLibCharRem
    bl xmlNewNode                         @ create root node
    mov r8,r0                             @ node characterisation address
    mov r0,r9                             @ doc
    mov r1,r8                             @ node root
    bl xmlDocSetRootElement
    ldr r4,iAdrtbNames
    ldr r5,iAdrtbRemarks
    mov r6,#0                             @ loop counter
1:                                        @ start loop
    mov r0,#0
    ldr r1,iAdrszLibChar                  @ create node
    bl xmlNewNode
    mov r7,r0                             @ node character
                                          @ r0 = node address
    ldr r1,iAdrszLibName
    ldr r2,[r4,r6,lsl #2]                 @ load name string address
    bl xmlNewProp
    ldr r0,[r5,r6,lsl #2]                 @ load remark string address
    bl xmlNewText
    mov r1,r0
    mov r0,r7
    bl xmlAddChild
    mov r0,r8
    mov r1,r7
    bl xmlAddChild
    add r6,#1
    ldr r2,[r4,r6,lsl #2]                  @ load name string address
    cmp r2,#0                              @ = zero ?
    bne 1b                                 @ no -> loop

    ldr r0,iAdrszFileName
    ldr r1,iAdrszFileMode
    bl fopen                               @ file open
    cmp r0,#0
    blt 99f
    mov r6,r0                              @FD
    mov r1,r9
    mov r2,r8
    bl xmlDocDump                          @ write doc on the file

    mov r0,r6
    bl fclose
    mov r0,r9
    bl xmlFreeDoc
    bl xmlCleanupParser
    ldr r0,iAdrszMessEndpgm
    bl affichageMess
    b 100f
99:
    @ error
    ldr r0,iAdrszMessError
    bl affichageMess
100:                                       @ standard end of the program
    mov r0, #0                             @ return code
    mov r7, #EXIT                          @ request to exit program
    svc #0                                 @ perform the system call

iAdrszMessError:          .int szMessError
iAdrszMessEndpgm:         .int szMessEndpgm
iAdrszVersDoc:            .int szVersDoc
iAdrszLibCharRem:         .int szLibCharRem
iAdrszLibChar:            .int szLibChar
iAdrszLibName:            .int szLibName
iAdrtbNames:              .int tbNames
iAdrtbRemarks:            .int tbRemarks
iAdrszCarriageReturn:     .int szCarriageReturn
iStdout:                  .int STDOUT
iAdrszFileName:           .int szFileName
iAdrszFileMode:           .int szFileMode
/******************************************************************/
/*     display text with size calculation                         */
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {r0,r1,r2,r7,lr}                   @ save  registres
    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"
    svc #0                                  @ call systeme
    pop {r0,r1,r2,r7,lr}                    @ restaur registers */
    bx lr                                   @ return
/******************************************************************/
/*     Converting a register to a decimal                                 */
/******************************************************************/
/* r0 contains value and r1 address area   */
.equ LGZONECAL,   10
conversion10:
    push {r1-r4,lr}                         @ save registers
    mov r3,r1
    mov r2,#LGZONECAL
1:                                          @ start loop
    bl divisionpar10                        @ r0 <- dividende. quotient ->r0 reste -> r1
    add r1,#48                              @ digit
    strb r1,[r3,r2]                         @ store digit on area
    cmp r0,#0                               @ stop if quotient = 0
    subne r2,#1                               @ previous position
    bne 1b                                  @ else loop
                                            @ end replaces digit in front of area
    mov r4,#0
2:
    ldrb r1,[r3,r2]
    strb r1,[r3,r4]                         @ store in area begin
    add r4,#1
    add r2,#1                               @ previous position
    cmp r2,#LGZONECAL                       @ end
    ble 2b                                  @ loop
    mov r1,#' '
3:
    strb r1,[r3,r4]
    add r4,#1
    cmp r4,#LGZONECAL                       @ end
    ble 3b
100:
    pop {r1-r4,lr}                          @ restaur registres
    bx lr                                   @return
/***************************************************/
/*   division par 10   signé                       */
/* Thanks to http://thinkingeek.com/arm-assembler-raspberry-pi/*
/* and   http://www.hackersdelight.org/            */
/***************************************************/
/* r0 dividende   */
/* r0 quotient */
/* r1 remainder  */
divisionpar10:
  /* r0 contains the argument to be divided by 10 */
    push {r2-r4}                           @ save registers  */
    mov r4,r0
    mov r3,#0x6667                         @ r3 <- magic_number  lower
    movt r3,#0x6666                        @ r3 <- magic_number  upper
    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                                  @ return


Y: closure [g] [do func [f] [f :f] closure [f] [g func [x] [do f :f :x]]]


gosub constants
names := xmlescape(names)
remarks := xmlescape(remarks)

stringsplit, remarks, remarks, `n
xml = "<CharacterRemarks>"

loop, parse, names, `n
  xml .= "<Character name=" . A_LoopField . ">" . remarks%A_Index%
  . "</Character>`n"

xml .= "</CharacterRemarks>"

msgbox % xml
return

xmlescape(string)
{
  static
  punc = ",>,<,<=,>=,',&  ; "
  xmlpunc = ",>,<,<=,>=,',&
  if !punc1
  {
	StringSplit, punc, punc, `,
	StringSplit, xmlpunc, xmlpunc, `,
  }
  escaped := string
  loop, parse, punc, `,
  {
  StringReplace, escaped, escaped, % A_LoopField, % xmlpunc%A_Index%, All
  }
  Return escaped
}

constants:
#LTrim
names =
(
  April
  Tam O'Shanter
  Emily
)

remarks =
(
  Bubbly: I'm > Tam and <= Emily
  Burns: "When chapman billies leave the street ..."
  Short & shrift
)
return


100 Q$ = CHR$(34)
110 DE$(0) = "April"
120 RE$(0) = "Bubbly: I'm > Tam and <= Emily"
130 DE$(1) = "Tam O'Shanter"
140 RE$(1) = "Burns: " + Q$ + "When chapman billies leave the street ..." + Q$
150 DE$(2) = "Emily"
160 RE$(2) = "Short & shrift"

200 Print "<CharacterRemarks>"
210 For I = 0 to 2
220    Print "    <Character name="Q$;
230    X$=DE$(I) : GOSUB 300xmlquote
240    PRINT Q$">";
250    X$=RE$(I) : GOSUB 300xmlquote
260    PRINT "</Character>"
270 Next
280 Print "</CharacterRemarks>"
290 End

300 For n = 1 To Len(X$)
310    c$ = Mid$(X$,n,1)
320    IF C$ = "<" THEN C$ = "<"
330    IF C$ = ">" THEN C$ = ">"
340    IF C$ = "&" THEN C$ = "&"
350    IF C$ = Q$ THEN C$ = """
360    IF C$ = "'" THEN C$ = "'"
370    PRINT C$;
380 NEXT N
390 RETURN


/*REXX program implements and displays  a  stateless   Y   combinator.                  */
numeric digits 1000                                               /*allow big numbers.  */
say '    fib'   Y(fib      (50) )                                 /*Fibonacci series.   */
say '    fib'   Y(fib      (12 11 10 9 8 7 6 5 4 3 2 1 0)  )      /*Fibonacci series.   */
say '   fact'   Y(fact     (60) )                                 /*single    factorial.*/
say '   fact'   Y(fact     (0 1 2 3 4 5 6 7 8 9 10 11) )          /*single    factorial.*/
say '  Dfact'   Y(dfact    (4 5 6 7 8 9 10 11 12 13)   )          /*double    factorial.*/
say '  Tfact'   Y(tfact    (4 5 6 7 8 9 10 11 12 13)   )          /*triple    factorial.*/
say '  Qfact'   Y(qfact    (4 5 6 7 8 40) )                       /*quadruple factorial.*/
say ' length'   Y(length   (when for to where whenceforth) )      /*lengths   of words. */
say 'reverse'   Y(reverse  (123 66188 3007 45.54 MAS I MA) )      /*reverses  strings.  */
say '   sign'   Y(sign     (-8 0 8) )                             /*sign of the numbers.*/
say '  trunc'   Y(trunc    (-7.0005 12 3.14159 6.4 78.999) )      /*truncates numbers.  */
say '    b2x'   Y(b2x      (1 10 11 100 1000 10000 11111 ) )      /*converts BIN──►HEX. */
say '    d2x'   Y(d2x      (8 9 10 11 12 88 89 90 91 6789) )      /*converts DEC──►HEX. */
say '    x2d'   Y(x2d      (8 9 10 11 12 88 89 90 91 6789) )      /*converts HEX──►DEC. */
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
Y: parse arg Y _; $=; do j=1 for words(_); interpret '$=$' Y"("word(_,j)')'; end; return $
/*──────────────────────────────────────────────────────────────────────────────────────*/
fib:   procedure; parse arg x;  if x<2  then return x;  s= 0;  a= 0;   b= 1
                                    do j=2  to x;  s= a+b;  a= b;  b= s;  end;    return s
/*──────────────────────────────────────────────────────────────────────────────────────*/
dfact: procedure; parse arg x;  != 1;    do j=x  to 2  by -2;   != !*j;   end;    return !
tfact: procedure; parse arg x;  != 1;    do j=x  to 2  by -3;   != !*j;   end;    return !
qfact: procedure; parse arg x;  != 1;    do j=x  to 2  by -4;   != !*j;   end;    return !
 fact: procedure; parse arg x;  != 1;    do j=2  to x       ;   != !*j;   end;    return !


( ( 2XML
  =     PCDATAentities attributeValueEntities doAll doAttributes
      , xml
    .   ( attributeValueEntities
        =   a c
          .     @( !arg
                 :   ?a
                     (("<"|"&"|\"):?c)
                     ?arg
                 )
              &   !a
                  "&"
                  ( !c:"<"&lt
                  | !c:"&"&amp
                  | quot
                  )
                  ";"
                  attributeValueEntities$!arg
            | !arg
        )
      & ( PCDATAentities
        =   a c
          .     @( !arg
                 :   ?a
                     (("<"|"&"|">"):?c)
                     ?arg
                 )
              &   !a
                  "&"
                  ( !c:"<"&lt
                  | !c:"&"&amp
                  | gt
                  )
                  ";"
                  PCDATAentities$!arg
            | !arg
        )
      & ( doAttributes
        =   a v
          .     !arg:(?a.?v) ?arg
              &   " "
                  PCDATAentities$!a
                  "=\""
                  attributeValueEntities$!v
                  \"
                  doAttributes$!arg
            |
        )
      & ( doAll
        =   xml first A B C att XML
          .   !arg:?xml
            & :?XML
            &   whl
              ' ( !xml:%?first ?xml
                & (   !first:(?A.?B)
                    & (   !B:(?att,?C)
                        &     !XML
                              (   !C:
                                & "<" !A doAttributes$!att " />\n"
                              |   "<"
                                  !A
                                  doAttributes$!att
                                  ">"
                                  doAll$!C
                                  "</"
                                  !A
                                  ">\n"
                              )
                          : ?XML
                      |   !A
                        : ( "!"&!XML "<!" !B ">":?XML
                          |   "!--"
                            & !XML "<!--" !B "-->":?XML
                          | "?"&!XML "<?" !B "?>\n":?XML
                          |   "![CDATA["
                            & !XML "<![CDATA[" !B "]]>":?XML
                          |   "!DOCTYPE"
                            & !XML "<!DOCTYPE" !B ">":?XML
                          |   ?
                            & !XML "<" !A doAttributes$!B ">":?XML
                          )
                      )
                  | !XML PCDATAentities$!first:?XML
                  )
                )
            & str$!XML
        )
      & doAll$!arg
  )
& ( makeList
  =   characters name names remark remarks
    .   !arg:(?names.?remarks)
      & :?characters
      &   whl
        ' (   (!names.!remarks)
            : (%?name ?names.%?remark ?remarks)
          &   !characters (Character.(name.!name),!remark)
            : ?characters
          )
      & ("?".xml) (CharacterRemarks.,!characters)
  )
&   put
  $ ( 2XML
    $ ( makeList
      $ ( April "Tam O'Shanter" Emily
        .   "Bubbly: I'm > Tam and <= Emily"
            "Burns: \"When chapman billies leave the street ...\""
            "Short & shrift"
        )
      )
    )
)


#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <libxml/parser.h>
#include <libxml/tree.h>

const char *names[] = {
  "April", "Tam O'Shanter", "Emily", NULL
};
const char *remarks[] = {
  "Bubbly: I'm > Tam and <= Emily",
  "Burns: \"When chapman billies leave the street ...\"",
  "Short & shrift", NULL
};

int main()
{
  xmlDoc *doc = NULL;
  xmlNode *root = NULL, *node;
  const char **next;
  int a;

  doc = xmlNewDoc("1.0");
  root = xmlNewNode(NULL, "CharacterRemarks");
  xmlDocSetRootElement(doc, root);

  for(next = names, a = 0; *next != NULL; next++, a++) {
    node = xmlNewNode(NULL, "Character");
    (void)xmlNewProp(node, "name", *next);
    xmlAddChild(node, xmlNewText(remarks[a]));
    xmlAddChild(root, node);
  }

  xmlElemDump(stdout, doc, root);

  xmlFreeDoc(doc);
  xmlCleanupParser();

  return EXIT_SUCCESS;
}


using System;
using System.Collections.Generic;
using System.Linq;
using System.Xml.Linq;

class Program
{
    static string CreateXML(Dictionary<string, string> characterRemarks)
    {
        var remarks = characterRemarks.Select(r => new XElement("Character", r.Value, new XAttribute("Name", r.Key)));
        var xml = new XElement("CharacterRemarks", remarks);
        return xml.ToString();
    }

    static void Main(string[] args)
    {
        var characterRemarks = new Dictionary<string, string>
        {
            { "April", "Bubbly: I'm > Tam and <= Emily" },
            { "Tam O'Shanter", "Burns: \"When chapman billies leave the street ...\"" },
            { "Emily", "Short & shrift" }
        };

        string xml = CreateXML(characterRemarks);
        Console.WriteLine(xml);
    }
}


//! A simple implementation of the Y Combinator:
//! λf.(λx.xx)(λx.f(xx))
//! <=> λf.(λx.f(xx))(λx.f(xx))

/// A function type that takes its own type as an input is an infinite recursive type.
/// We introduce the "Apply" trait, which will allow us to have an input with the same type as self, and break the recursion.
/// The input is going to be a trait object that implements the desired function in the interface.
trait Apply<T, R> {
    fn apply(&self, f: &dyn Apply<T, R>, t: T) -> R;
}

/// If we were to pass in self as f, we get:
/// λf.λt.sft
/// => λs.λt.sst [s/f]
/// => λs.ss
impl<T, R, F> Apply<T, R> for F where F: Fn(&dyn Apply<T, R>, T) -> R {
    fn apply(&self, f: &dyn Apply<T, R>, t: T) -> R {
        self(f, t)
    }
}

/// (λt(λx.(λy.xxy))(λx.(λy.f(λz.xxz)y)))t
/// => (λx.xx)(λx.f(xx))
/// => Yf
fn y<T, R>(f: impl Fn(&dyn Fn(T) -> R, T) -> R) -> impl Fn(T) -> R {
    move |t| (&|x: &dyn Apply<T, R>, y| x.apply(x, y))
             (&|x: &dyn Apply<T, R>, y| f(&|z| x.apply(x, z), y), t)
}

/// Factorial of n.
fn fac(n: usize) -> usize {
    let almost_fac = |f: &dyn Fn(usize) -> usize, x| if x == 0 { 1 } else { x * f(x - 1) };
    y(almost_fac)(n)
}

/// nth Fibonacci number.
fn fib(n: usize) -> usize {
    let almost_fib = |f: &dyn Fn((usize, usize, usize)) -> usize, (a0, a1, x)|
        match x {
            0 => a0,
            1 => a1,
            _ => f((a1, a0 + a1, x - 1)),
        };

    y(almost_fib)((1, 1, n))
}

/// Driver function.
fn main() {
    let n = 10;
    println!("fac({}) = {}", n, fac(n));
    println!("fib({}) = {}", n, fib(n));
}


#include <vector>
#include <utility>
#include <iostream>
#include <boost/algorithm/string.hpp>

std::string create_xml( std::vector<std::string> & ,std::vector<std::string> & ) ;

int main( ) {
   std::vector<std::string> names , remarks ;
   names.push_back( "April" ) ;
   names.push_back( "Tam O'Shantor" ) ;
   names.push_back ( "Emily" ) ;
   remarks.push_back( "Bubbly, I'm > Tam and <= Emily" ) ;
   remarks.push_back( "Burns: \"When chapman billies leave the street ...\"" ) ;
   remarks.push_back( "Short & shrift" ) ;
   std::cout << "This is in XML:\n" ;
   std::cout << create_xml( names , remarks ) << std::endl ;
   return 0 ;
}

std::string create_xml( std::vector<std::string> & names ,
      std::vector<std::string> & remarks ) {
   std::vector<std::pair<std::string , std::string> > entities ;
   entities.push_back( std::make_pair( "&" , "&" ) ) ;
   entities.push_back( std::make_pair( "<" , "<" ) ) ;
   entities.push_back( std::make_pair( ">" , ">" ) ) ;
   std::string xmlstring ( "<CharacterRemarks>\n" ) ;
   std::vector<std::string>::iterator vsi = names.begin( ) ;
   typedef std::vector<std::pair<std::string , std::string> >::iterator Vpss ;
   for ( ; vsi != names.end( ) ; vsi++ ) {
      for ( Vpss vs = entities.begin( ) ; vs != entities.end( ) ; vs++ ) {
	 boost::replace_all ( *vsi , vs->first , vs->second ) ;
      }
   }
   for ( vsi = remarks.begin( ) ; vsi != remarks.end( ) ; vsi++ ) {
      for ( Vpss vs = entities.begin( ) ; vs != entities.end( ) ; vs++ ) {
	 boost::replace_all ( *vsi , vs->first , vs->second ) ;
      }
   }
   for ( int i = 0 ; i < names.size( ) ; i++ ) {
      xmlstring.append( "\t<Character name=\"").append( names[ i ] ).append( "\">")
	 .append( remarks[ i ] ).append( "</Character>\n" ) ;
   }
   xmlstring.append( "</CharacterRemarks>" ) ;
   return xmlstring ;
}


(define Y                 ; (Y f) = (g g) where
  (lambda (f)             ;         (g g) = (f  (lambda a (apply (g g) a)))
    ((lambda (g) (g g))   ; (Y f) ==        (f  (lambda a (apply (Y f) a)))
     (lambda (g)
       (f  (lambda a (apply (g g) a)))))))

;; head-recursive factorial
(define fac                ; fac = (Y f) = (f      (lambda a (apply (Y f) a)))
  (Y (lambda (r)           ;     = (lambda (x) ... (r     (- x 1)) ... )
       (lambda (x)         ;        where   r    = (lambda a (apply (Y f) a))
         (if (< x 2)       ;               (r ... ) == ((Y f) ... )
             1             ;     == (lambda (x) ... (fac  (- x 1)) ... )
             (* x (r (- x 1))))))))

;; tail-recursive factorial
(define fac2
  (lambda (x)
    ((Y (lambda (r)        ;       (Y f) == (f     (lambda a (apply (Y f) a)))
          (lambda (x acc)  ;          r         == (lambda a (apply (Y f) a))
            (if (< x 2)    ;         (r ... )   == ((Y f) ... )
                acc
                (r (- x 1) (* x acc))))))
     x 1)))

; double-recursive Fibonacci
(define fib
  (Y (lambda (f)
       (lambda (x)
         (if (< x 2)
             x
             (+ (f (- x 1)) (f (- x 2))))))))

; tail-recursive Fibonacci
(define fib2
  (lambda (x)
    ((Y (lambda (f)
          (lambda (x a b)
            (if (< x 1)
                a
                (f (- x 1) b (+ a b))))))
     x 0 1)))

(display (fac 6))
(newline)

(display (fib2 134))
(newline)


(use 'clojure.xml)
(defn character-remarks-xml [characters remarks]
  (with-out-str (emit-element
                  {:tag :CharacterRemarks,
                   :attrs nil,
                   :content (vec (for [item (map vector characters remarks)]
                                   {:tag :Character,
                                    :attrs {:name (item 0)},
                                    :content [(item 1)]}) )})))


(defun write-xml (characters lines &optional (out *standard-output*))
  (let* ((doc (dom:create-document 'rune-dom:implementation nil nil nil))
         (chars (dom:append-child doc (dom:create-element doc "Characters"))))
    (map nil (lambda (character line)
               (let ((c (dom:create-element doc "Character")))
                 (dom:set-attribute c "name" character)
                 (dom:append-child c (dom:create-text-node doc line))
                 (dom:append-child chars c)))
         characters lines)
    (write-string (dom:map-document (cxml:make-rod-sink) doc) out)))