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

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

.equ NBTIRAGES,     4
.equ NBTIRAGESOK,   3
.equ NBVALUES,      6
.equ TOTALMIN,      75
.equ MAXVALUE,      15
.equ NBMAXVALUE,    2

/*********************************/
/* Initialized data              */
/*********************************/
.data
sMessResult:        .asciz "Value  = @ \n"
szCarriageReturn:   .asciz "\n"
sMessResultT:       .asciz "Total  = @ \n"
sMessResultQ:       .asciz "Values above 15  = @ \n"

.align 4
qGraine:  .quad 123456789

/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
tqTirages:               .skip  8 * NBTIRAGES
tqValues:                .skip  8 * NBVALUES

sZoneConv:               .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                  // entry of program

1:                                     // begin loop 1
    mov x2,0                           // counter value >15
    mov x4,0                           // loop indice
    mov x5,0                           // total
    ldr x3,qAdrtqValues                // table values address
2:
    bl genValue                        // call generate value
    str x0,[x3,x4,lsl 3]               // store in table
    add x5,x5,x0                       // compute total
    cmp x0,MAXVALUE                    // count value >= 15
    add x6,x2,1
    csel x2,x6,x2,ge
    add x4,x4,1                        // increment indice
    cmp x4,NBVALUES                    // end ?
    blt 2b
    cmp x5,TOTALMIN                    // compare 75
    blt 1b                             // < loop
    cmp x2,#NBMAXVALUE                 // compare value > 15
    blt 1b                             // < loop
    ldr x0,qAdrtqValues                // display values
    bl displayTable
    mov x0,x5                          // total

    ldr x1,qAdrsZoneConv               // display value
    bl conversion10                    // call conversion decimal
    ldr x0,qAdrsMessResultT
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc              // insert result at @ character
    bl affichageMess                   // display message

     mov x0,x2                         // counter value > 15
    ldr x1,qAdrsZoneConv               // display value
    bl conversion10                    // call conversion decimal
    ldr x0,qAdrsMessResultQ
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc              // insert result at @ character
    bl affichageMess                   // display message

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

qAdrsZoneConv:            .quad sZoneConv
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrsMessResultT:         .quad sMessResultT
qAdrsMessResultQ:         .quad sMessResultQ
qAdrtqValues:             .quad tqValues
/******************************************************************/
/*     generate value                                  */
/******************************************************************/
/* x0 returns the value             */
genValue:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    mov x3,0                       // indice loop
    ldr x1,qAdrtqTirages           // table tirage address
1:
    mov x0,6
    bl genereraleas                // result 0 to 5
    add x0,x0,#1                   // for 1 to 6
    str x0,[x1,x3,lsl 3]           // store tirage
    add x3,x3,1                    // increment indice
    cmp x3,NBTIRAGES               // end ?
    blt 1b                         // no -> loop
    ldr x0,qAdrtqTirages           // table tirage address
    mov x1,#0                      // first item
    mov x2,#NBTIRAGES              // number of tirages
    bl shellSort                   // sort table decreasing
    mov x3,#0                      // raz indice loop
    mov x0,#0                      // total
    ldr x1,qAdrtqTirages           // table tirage address
2:
    ldr x2,[x1,x3,lsl 3]           // read tirage
    add x0,x0,x2                   // compute sum
    add x3,x3,1                    // increment indice
    cmp x3,NBTIRAGESOK             // end ?
    blt 2b
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
qAdrtqTirages:           .quad tqTirages
/***************************************************/
/*   shell Sort  decreasing                                  */
/***************************************************/
/* x0 contains the address of table */
/* x1 contains the first element but not use !!   */
/*   this routine use first element at index zero !!!  */
/* x2 contains the number of element */
shellSort:
    stp x1,lr,[sp,-16]!          // save  registers
    stp x2,x3,[sp,-16]!          // save  registers
    stp x4,x5,[sp,-16]!          // save  registers
    stp x6,x7,[sp,-16]!          // save  registers
    stp x8,x9,[sp,-16]!          // save  registers
    sub x2,x2,1                     // index last item
    mov x1,x2                    // init gap = last item
1:                               // start loop 1
    lsr x1,x1,1                 // gap = gap / 2
    cbz x1,100f                     // if gap = 0 -> end
    mov x3,x1                    // init loop indice 1
2:                               // start loop 2
    ldr x4,[x0,x3,lsl 3]         // load first value
    mov x5,x3                    // init loop indice 2
3:                               // start loop 3
    cmp x5,x1                    // indice < gap
    blt 4f                       // yes -> end loop 2
    sub x6,x5,x1                 // index = indice - gap
    ldr x8,[x0,x6,lsl 3]         // load second value
    cmp x4,x8                    // compare values
    ble 4f
    str x8,[x0,x5,lsl 3]         // store if >
    sub x5,x5,x1                    // indice = indice - gap
    b 3b                         // and loop
4:                               // end loop 3
    str x4,[x0,x5,lsl 3]         // store value 1 at indice 2
    add x3,x3,1                  // increment indice 1
    cmp x3,x2                    // end ?
    ble 2b                       // no -> loop 2
    b 1b                         // yes loop for new gap

100:                             // end function
    ldp x8,x9,[sp],16            // restaur  2 registers
    ldp x6,x7,[sp],16            // restaur  2 registers
    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

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* x0 contains the address of table */
displayTable:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    mov x2,x0                      // table address
    mov x3,0
1:                                 // loop display table
    ldr x0,[x2,x3,lsl 3]
    ldr x1,qAdrsZoneConv           // display value
    bl conversion10                // call function
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc          // insert result at @ character
    bl affichageMess               // display message
    add x3,x3,1
    cmp x3,NBVALUES - 1
    ble 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30

/***************************************************/
/*   Generation random number                      */
/*    algo xorshift (see wikipedia)                */
/***************************************************/
/* x0 contains limit  */
genereraleas:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    cbz x0,100f
    mov x3,x0           // maxi value
    ldr x0,qAdrqGraine  // graine
    ldr x2,[x0]
    lsl x1,x2,13
    eor x2,x2,x1
    lsr x1,x2,7
    eor x2,x2,x1
    lsl x1,x2,17
    eor x1,x2,x1
    str x1,[x0]         // sauver graine
    udiv x2,x1,x3       //
    msub x0,x2,x3,x1    // compute result modulo limit

100:                    // end function
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/*****************************************************/
qAdrqGraine: .quad qGraine
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


TYPE Result=[BYTE success,sum,highCount]
BYTE FUNC GenerateAttrib()
  BYTE i,v,min,sum

  min=255 sum=0
  FOR i=0 TO 3
  DO
    v=Rand(6)+1
    IF v<min THEN
      min=v
    FI
    sum==+v
  OD
RETURN (sum-min)

PROC Generate(BYTE ARRAY a BYTE len Result POINTER res)
  BYTE i,v,count

  res.highCount=0 res.sum=0
  FOR i=0 TO len-1
  DO
    v=GenerateAttrib()
    IF v>=15 THEN
      res.highCount==+1
    FI
    res.sum==+v
    a(i)=v
  OD
  IF res.highCount<2 OR res.sum<75 THEN
    res.success=0
  ELSE
    res.success=1
  FI
RETURN

PROC Main()
  DEFINE count="6"
  BYTE ARRAY a(count)
  Result res
  BYTE i

  res.success=0
  WHILE res.success=0
  DO
    Generate(a,count,res)
    Print("attribs: ")
    FOR i=0 TO count-1
    DO
      PrintB(a(i))
      IF i<count-1 THEN
        Put(',)
      FI
    OD
    PrintF(" sum=%B highCount=%B ",res.sum,res.highCount)
    IF res.success THEN
      PrintE("success")
    ELSE
      PrintE("failed")
    FI
  OD
RETURN


BEGIN # RPG attributes generator #

    INT attrib count = 6;
    MODE RESULT = STRUCT( BOOL success, INT sum, high count, [ 1 : attrib count ]INT a );

    PROC generate attrib = INT:
    BEGIN
        INT min := 255, sum := 0;
        FOR i FROM 0 TO 3 DO
            INT v = ENTIER( next random * 6 ) + 1;
            IF v < min THEN
                min := v
            FI;
            sum +:= v
        OD;
        sum - min
    END # generate attrib #;

    PROC generate = ( REF RESULT res )VOID:
    BEGIN
        high count OF res := 0;
        sum OF res        := 0;
        FOR i FROM LWB a OF res TO UPB a OF res DO
            INT v = generate attrib;
            IF v >= 15 THEN
               high count OF res +:= 1
            FI;
            sum OF res +:= v;
            ( a OF res )[ i ] := v
        OD;
        success OF res := ( high count OF res >= 2 AND sum OF res >= 75 )
    END # generate # ;

    RESULT res;
    success OF res := FALSE;
    WHILE NOT success OF res DO
        generate( res );
        print( ( "attribs: " ) );
        FOR i FROM LWB a OF res TO UPB a OF res DO
            print( ( whole( ( a OF res )[ i ], 0 ) ) );
            IF i < UPB a OF res THEN
                print( ( " " ) )
            FI
        OD;
        print( ( " sum=", whole( sum OF res, 0 )
               , " highCount=", whole( high count OF res, 0 )
               , " ", IF success OF res THEN "success" ELSE "failed" FI
               , newline
               )
             )
    OD

END


        .model small       ; 128k .exe file
        .stack 1024        ; load SP with 0400h
        .data              ; no data segment needed

	.code

start:

	mov ax,@code
	mov ds,ax
	mov es,ax

	mov si,offset TestString
	mov di,offset OutputRam

	cld

compressRLE:
	lodsb
	cmp al,0                     ;null terminator?
	jz finished_Compressing      ;if so, exit
	push di
	push si
		mov cx,0FFFFh	;exit after 65536 reps or the run length ends.
		xchg di,si      ;scasb only works with es:di so we need to exchange
		repz scasb   	;repeat until [es:di] != AL
		xchg di,si      ;exchange back
	pop dx                  ;pop the old SI into DX instead!
	pop di

	push si
		sub si,dx
		mov dx,si
	pop si
	;now the run length is in dx, store it into output ram.

	push ax
		mov al,dl
		stosb
	pop ax
	stosb    ;store the letter that corresponds to the run

	dec si   ;we're off by one, so we need to correct for that.
	jmp compressRLE   ;back to start

finished_Compressing:

	mov bp, offset OutputRam
	mov bx, 32
	call doMemDump        ;displays a hexdump of the contents of OutputRam

	mov ax,4C00h
	int 21h		      ;exit DOS

TestString byte "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW",0

OutputRam byte 256 dup (0)

end start


import std.stdio, std.conv, std.algorithm, std.variant, std.uni,
       std.functional, std.string;

alias Sexp = Variant;

struct Symbol {
    private string name;
    string toString() @safe const pure nothrow { return name; }
}

Sexp parseSexp(string txt) @safe pure /*nothrow*/ {
    static bool isIdentChar(in char c) @safe pure nothrow {
        return c.isAlpha || "0123456789[email protected]#-".representation.canFind(c);
    }

    size_t pos = 0;

    Sexp _parse() /*nothrow*/ {
        auto i = pos + 1;
        scope (exit)
            pos = i;
        if (txt[pos] == '"') {
            while (txt[i] != '"' && i < txt.length)
                i++;
            i++;
            return Sexp(txt[pos + 1 .. i - 1]);
        } else if (txt[pos].isNumber) {
            while (txt[i].isNumber && i < txt.length)
                i++;
            if (txt[i] == '.') {
                i++;
                while (txt[i].isNumber && i < txt.length)
                    i++;
                auto aux = txt[pos .. i]; //
                return aux.parse!double.Sexp;
            }
            auto aux = txt[pos .. i]; //
            return aux.parse!ulong.Sexp;
        } else if (isIdentChar(txt[pos])) {
            while (isIdentChar(txt[i]) && i < txt.length)
                i++;
            return Sexp(Symbol(txt[pos .. i]));
        } else if (txt[pos] == '(') {
            Sexp[] lst;
            while (txt[i] != ')') {
                while (txt[i].isWhite)
                    i++;
                pos = i;
                lst ~= _parse;
                i = pos;
                while (txt[i].isWhite)
                    i++;
            }
            i = pos + 1;
            return Sexp(lst);
        }
        return Sexp(null);
    }

    txt = txt.find!(not!isWhite);
    return _parse;
}

void writeSexp(Sexp expr) {
    if (expr.type == typeid(string)) {
        write('"', expr, '"');
    } else if (expr.type == typeid(Sexp[])) {
        '('.write;
        auto arr = expr.get!(Sexp[]);
        foreach (immutable i, e; arr) {
            e.writeSexp;
            if (i + 1 < arr.length)
                ' '.write;
        }
        ')'.write;
    } else {
        expr.write;
    }
}

void main() {
    auto pTest = `((data "quoted data" 123 4.5)
                   (data ([email protected]# (4.5) "(more" "data)")))`.parseSexp;
    writeln("Parsed: ", pTest);
    "Printed: ".write;
    pTest.writeSexp;
}


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

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

.equ NBTIRAGES,     4
.equ NBTIRAGESOK,   3
.equ NBVALUES,      6
.equ TOTALMIN,      75
.equ MAXVALUE,      15
.equ NBMAXVALUE,    2
/*******************************************/
/* Fichier des macros                       */
/********************************************/
.include "../../ficmacros.s"

/*********************************/
/* Initialized data              */
/*********************************/
.data
sMessResult:        .ascii "Value  = "
sMessValeur:        .fill 11, 1, ' '            @ size => 11
szCarriageReturn:   .asciz "\n"
sMessResultT:       .ascii "Total  = "
sMessValeurT:       .fill 11, 1, ' '            @ size => 11
                    .asciz "\n"
sMessResultQ:       .ascii "Values above 15  = "
sMessValeurQ:       .fill 11, 1, ' '            @ size => 11
                    .asciz "\n"

.align 4
iGraine:  .int 123456

/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
tiTirages:               .skip  4 * NBTIRAGES
tiValues:                .skip  4 * NBVALUES
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                             @ entry of program

1:                                                @ begin loop 1
    mov r2,#0                                     @ counter value >15
    mov r4,#0                                     @ loop indice
    mov r5,#0                                     @ total
    ldr r3,iAdrtiValues                           @ table values address
2:
    bl genValue                                   @ call generate value
    str r0,[r3,r4,lsl #2]                         @ store in table
    add r5,r0                                     @ compute total
    cmp r0,#MAXVALUE                                    @ count value > 15
    addge r2,#1
    add r4,#1                                     @ increment indice
    cmp r4,#NBVALUES                              @ end ?
    blt 2b
    cmp r5,#TOTALMIN                              @ compare 75
    blt 1b                                        @ < loop
    cmp r2,#NBMAXVALUE                                     @ compare value > 15
    blt 1b                                        @ < loop
    ldr r0,iAdrtiValues                           @ display values
    bl displayTable
    mov r0,r5                                     @ total
    ldr r1,iAdrsMessValeurT                       @ display value
    bl conversion10                               @ call conversion decimal
    ldr r0,iAdrsMessResultT
    bl affichageMess                              @ display message

     mov r0,r2                                    @ counter value > 15
    ldr r1,iAdrsMessValeurQ                       @ display value
    bl conversion10                               @ call conversion decimal
    ldr r0,iAdrsMessResultQ
    bl affichageMess                              @ display message

100:                                              @ standard end of the program
    mov r0, #0                                    @ return code
    mov r7, #EXIT                                 @ request to exit program
    svc #0                                        @ perform the system call

iAdrsMessValeur:          .int sMessValeur
iAdrszCarriageReturn:     .int szCarriageReturn
iAdrsMessResult:          .int sMessResult
iAdrsMessValeurT:         .int sMessValeurT
iAdrsMessResultT:         .int sMessResultT
iAdrsMessValeurQ:         .int sMessValeurQ
iAdrsMessResultQ:         .int sMessResultQ
iAdrtiValues:             .int tiValues
/******************************************************************/
/*     generate value                                  */
/******************************************************************/
/* r0 returns the value             */
genValue:
    push {r1-r4,lr}                           @ save registers
    mov r4,#0                                 @ indice loop
    ldr r1,iAdrtiTirages                      @ table tirage address
1:
    mov r0,#6
    bl genereraleas                           @ result 0 to 5
    add r0,#1                                 @ for 1 to 6
    str r0,[r1,r4,lsl #2]                     @ store tirage
    add r4,#1                                 @ increment indice
    cmp r4,#NBTIRAGES                         @ end ?
    blt 1b                                    @ no -> loop
    ldr r0,iAdrtiTirages                      @ table tirage address
    mov r1,#0                                 @ first item
    mov r2,#NBTIRAGES                         @ number of tirages
    bl shellSort                              @ sort table decreasing
    mov r4,#0                                 @ raz indice loop
    mov r0,#0                                 @ total
    ldr r1,iAdrtiTirages                      @ table tirage address
2:
    ldr r2,[r1,r4,lsl #2]                     @ read tirage
    add r0,r2                                 @ compute sum
    add r4,#1                                 @ inrement indice
    cmp r4,#NBTIRAGESOK                       @ end ?
    blt 2b
100:
    pop {r1-r4,lr}
    bx lr                                     @ return
iAdrtiTirages:           .int tiTirages
/***************************************************/
/*   shell Sort  decreasing                                  */
/***************************************************/
/* r0 contains the address of table */
/* r1 contains the first element but not use !!   */
/*   this routine use first element at index zero !!!  */
/* r2 contains the number of element */
shellSort:
    push {r0-r7,lr}              @save registers

    sub r2,#1                    @ index last item
    mov r1,r2                    @ init gap = last item
1:                               @ start loop 1
    lsrs r1,#1                   @ gap = gap / 2
    beq 100f                     @ if gap = 0 -> end
    mov r3,r1                    @ init loop indice 1
2:                               @ start loop 2
    ldr r4,[r0,r3,lsl #2]        @ load first value
    mov r5,r3                    @ init loop indice 2
3:                               @ start loop 3
    cmp r5,r1                    @ indice < gap
    blt 4f                       @ yes -> end loop 2
    sub r6,r5,r1                 @ index = indice - gap
    ldr r7,[r0,r6,lsl #2]        @ load second value
    cmp r4,r7                    @ compare values
    strgt r7,[r0,r5,lsl #2]      @ store if >
    subgt r5,r1                  @ indice = indice - gap
    bgt 3b                       @ and loop
4:                               @ end loop 3
    str r4,[r0,r5,lsl #2]        @ store value 1 at indice 2
    add r3,#1                    @ increment indice 1
    cmp r3,r2                    @ end ?
    ble 2b                       @ no -> loop 2
    b 1b                         @ yes loop for new gap

100:                             @ end function
    pop {r0-r7,lr}               @ restaur registers
    bx lr                        @ return

/******************************************************************/
/*      Display table elements                                */
/******************************************************************/
/* r0 contains the address of table */
displayTable:
    push {r0-r3,lr}                                    @ save registers
    mov r2,r0                                          @ table address
    mov r3,#0
1:                                                     @ loop display table
    ldr r0,[r2,r3,lsl #2]
    ldr r1,iAdrsMessValeur                             @ display value
    bl conversion10                                    @ call function
    ldr r0,iAdrsMessResult
    bl affichageMess                                   @ display message
    add r3,#1
    cmp r3,#NBVALUES - 1
    ble 1b
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
100:
    pop {r0-r3,lr}
    bx lr
/******************************************************************/
/*     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 des  2 registres */
    bx lr                                          @ return
/******************************************************************/
/*     Converting a register to a decimal unsigned                */
/******************************************************************/
/* r0 contains value and r1 address area   */
/* r0 return size of result (no zero final in area) */
/* area size => 11 bytes          */
.equ LGZONECAL,   10
conversion10:
    push {r1-r4,lr}                                 @ save registers
    mov r3,r1
    mov r2,#LGZONECAL

1:                                                  @ start loop
    bl divisionpar10U                               @ unsigned  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                                     @ else previous position
    bne 1b                                          @ and loop
                                                    @ and move digit from left of area
    mov r4,#0
2:
    ldrb r1,[r3,r2]
    strb r1,[r3,r4]
    add r2,#1
    add r4,#1
    cmp r2,#LGZONECAL
    ble 2b
                                                      @ and move spaces in end on area
    mov r0,r4                                         @ result length
    mov r1,#' '                                       @ space
3:
    strb r1,[r3,r4]                                   @ store space in area
    add r4,#1                                         @ next position
    cmp r4,#LGZONECAL
    ble 3b                                            @ loop if r4 <= area size

100:
    pop {r1-r4,lr}                                    @ restaur registres
    bx lr                                             @return

/***************************************************/
/*   division par 10   unsigned                    */
/***************************************************/
/* r0 dividende   */
/* r0 quotient */
/* r1 remainder  */
divisionpar10U:
    push {r2,r3,r4, lr}
    mov r4,r0                                          @ save value
    //mov r3,#0xCCCD                                   @ r3 <- magic_number lower  raspberry 3
    //movt r3,#0xCCCC                                  @ r3 <- magic_number higter raspberry 3
    ldr r3,iMagicNumber                                @ r3 <- magic_number    raspberry 1 2
    umull r1, r2, r3, r0                               @ r1<- Lower32Bits(r1*r0) r2<- Upper32Bits(r1*r0)
    mov r0, r2, LSR #3                                 @ r2 <- r2 >> shift 3
    add r2,r0,r0, lsl #2                               @ r2 <- r0 * 5
    sub r1,r4,r2, lsl #1                               @ r1 <- r4 - (r2 * 2)  = r4 - (r0 * 10)
    pop {r2,r3,r4,lr}
    bx lr                                              @ leave function
iMagicNumber:  	.int 0xCCCCCCCD
/***************************************************/
/*   Generation random number                  */
/***************************************************/
/* r0 contains limit  */
genereraleas:
    push {r1-r4,lr}                                    @ save registers
    ldr r4,iAdriGraine
    ldr r2,[r4]
    ldr r3,iNbDep1
    mul r2,r3,r2
    ldr r3,iNbDep1
    add r2,r2,r3
    str r2,[r4]                                        @ maj de la graine pour appel suivant
    cmp r0,#0
    beq 100f
    mov r1,r0                                          @ divisor
    mov r0,r2                                          @ dividende
    bl division
    mov r0,r3                                          @ résult = remainder

100:                                                   @ end function
    pop {r1-r4,lr}                                     @ restaur registers
    bx lr                                              @ return
/*****************************************************/
iAdriGraine: .int iGraine
iNbDep1: .int 0x343FD
iNbDep2: .int 0x269EC3
/***************************************************/
/* integer division unsigned                       */
/***************************************************/
division:
    /* r0 contains dividend */
    /* r1 contains divisor */
    /* r2 returns quotient */
    /* r3 returns remainder */
    push {r4, lr}
    mov r2, #0                                         @ init quotient
    mov r3, #0                                         @ init remainder
    mov r4, #32                                        @ init counter bits
    b 2f
1:                                                     @ loop
    movs r0, r0, LSL #1                                @ r0 <- r0 << 1 updating cpsr (sets C if 31st bit of r0 was 1)
    adc r3, r3, r3                                     @ r3 <- r3 + r3 + C. This is equivalent to r3 ? (r3 << 1) + C
    cmp r3, r1                                         @ compute r3 - r1 and update cpsr
    subhs r3, r3, r1                                   @ if r3 >= r1 (C=1) then r3 <- r3 - r1
    adc r2, r2, r2                                     @ r2 <- r2 + r2 + C. This is equivalent to r2 <- (r2 << 1) + C
2:
    subs r4, r4, #1                                    @ r4 <- r4 - 1
    bpl 1b                                             @ if r4 >= 0 (N=0) then loop
    pop {r4, lr}
    bx lr


BYTE FUNC GetLength(CHAR ARRAY s BYTE pos)
  CHAR c
  BYTE len

  c=s(pos)
  len=1
  DO
    pos==+1
    IF pos<=s(0) AND s(pos)=c THEN
      len==+1
    ELSE
      EXIT
    FI
  OD
RETURN (len)

BYTE FUNC GetNumber(CHAR ARRAY s BYTE POINTER pos)
  BYTE num,len
  CHAR ARRAY tmp(5)

  len=0
  DO
    len==+1
    tmp(len)=s(pos^)
    pos^==+1
    IF s(pos^)<'0 OR s(pos^)>'9 THEN
      EXIT
    FI
  OD
  tmp(0)=len
  num=ValB(tmp)
RETURN (num)

PROC Append(CHAR ARRAY text,suffix)
  BYTE POINTER srcPtr,dstPtr
  BYTE len

  len=suffix(0)
  IF text(0)+len>255 THEN
    len=255-text(0)
  FI
  IF len THEN
    srcPtr=suffix+1
    dstPtr=text+text(0)+1
    MoveBlock(dstPtr,srcPtr,len)
    text(0)==+suffix(0)
  FI
RETURN

PROC Encode(CHAR ARRAY in,out)
  BYTE pos,len
  CHAR ARRAY tmp(5)

  pos=1 len=0 out(0)=0
  WHILE pos<=in(0)
  DO
    len=GetLength(in,pos)
    StrB(len,tmp)
    Append(out,tmp)
    out(0)==+1
    out(out(0))=in(pos)
    pos==+len
  OD
RETURN

PROC Decode(CHAR ARRAY in,out)
  BYTE pos,num,i
  CHAR c

  pos=1 out(0)=0
  WHILE pos<=in(0)
  DO
    num=GetNumber(in,@pos)
    c=in(pos)
    pos==+1
    FOR i=1 TO num
    DO
      out(0)==+1
      out(out(0))=c
    OD
  OD
RETURN

PROC Main()
  CHAR ARRAY data="WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"
  CHAR ARRAY encoded(256),decoded(256)

  PrintE("original:")
  PrintE(data)
  PutE()

  Encode(data,encoded)
  PrintE("encoded:")
  PrintE(encoded)
  PutE()

  Decode(encoded,decoded)
  PrintE("decoded:")
  PrintE(decoded)
RETURN


with Ada.Text_IO;        use Ada.Text_IO;
with Ada.Strings.Fixed;  use Ada.Strings.Fixed;
procedure Test_Run_Length_Encoding is
   function Encode (Data : String) return String is
   begin
      if Data'Length = 0 then
         return "";
      else
         declare
            Code  : constant Character := Data (Data'First);
            Index : Integer := Data'First + 1;
         begin
            while Index <= Data'Last and then Code = Data (Index) loop
               Index := Index + 1;
            end loop;
            declare
               Prefix : constant String := Integer'Image (Index - Data'First);
            begin
               return Prefix (2..Prefix'Last) & Code & Encode (Data (Index..Data'Last));
            end;
         end;
      end if;
   end Encode;
   function Decode (Data : String) return String is
   begin
      if Data'Length = 0 then
         return "";
      else
         declare
            Index : Integer := Data'First;
            Count : Natural := 0;
         begin
            while Index < Data'Last and then Data (Index) in '0'..'9' loop
               Count := Count * 10 + Character'Pos (Data (Index)) - Character'Pos ('0');
               Index := Index + 1;
            end loop;
            if Index > Data'First then
               return Count * Data (Index) & Decode (Data (Index + 1..Data'Last));
            else
               return Data;
            end if;
         end;
      end if;
   end Decode;
begin
   Put_Line (Encode ("WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"));
   Put_Line (Decode ("12W1B12W3B24W1B14W"));
end Test_Run_Length_Encoding;


(define input-string #'((data "quoted data" 123 4.5)\n(data (!@# (4.5) "(more" "data)")))'#)

input-string
    → "((data "quoted data" 123 4.5)
    (data ([email protected]# (4.5) "(more" "data)")))"

(define s-expr (read-from-string input-string))
s-expr
    → ((data "quoted data" 123 4.5) (data (!@# (4.5) "(more" "data)")))

(first s-expr)
    → (data "quoted data" 123 4.5)
(first(first s-expr))
    → data
(first(rest s-expr))
    → (data (!@# (4.5) "(more" "data)"))


module SExpr
(* This module is a very simple port of the OCaml version to F# (F-Sharp) *)
(* The original OCaml setatment is comment out and the F# statement(s) follow *)
(* Port performed by Bob Elward 23 Feb 2020 *)

(* The .Net standard would use "+" and not "^" for string concatenation *)
(* I kept the "^" to be compatable with the "ml" standard *)
(* The line below eliminates the warning/suggestion to use "+" *)
#nowarn "62"

(** This module is a very simple parsing library for S-expressions. *)
(* Copyright (C) 2009  Florent Monnier, released under MIT license. *)
(* modified to match the task description *)

(* Code obtained from: https://rosettacode.org/wiki/S-Expressions#OCaml *)

(* Note: The type below defines the grammar for this S-Expression (S-Expr).
         An S-Expr is either an Atom or an S-Expr
*)

open System.Text
open System.IO
open System

type sexpr = Atom of string | Expr of sexpr list

type state =
 | Parse_root of sexpr list
 | Parse_content of sexpr list
 | Parse_word of StringBuilder * sexpr list
 | Parse_string of bool * StringBuilder * sexpr list

let parse pop_char =
 let rec aux st =
   match pop_char() with
   | None ->
       begin match st with
       | Parse_root sl -> (List.rev sl)
       | Parse_content _
       | Parse_word _
       | Parse_string _ ->
           failwith "Parsing error: content not closed by parenthesis"
       end
   | Some c ->
       match c with
       | '(' ->
           begin match st with
           | Parse_root sl ->
               let this = aux(Parse_content []) in
               aux(Parse_root((Expr this)::sl))
           | Parse_content sl ->
               let this = aux(Parse_content []) in
               aux(Parse_content((Expr this)::sl))
           | Parse_word(w, sl) ->
               let this = aux(Parse_content []) in
               (* aux(Parse_content((Expr this)::Atom(Buffer.contents w)::sl)) *)
               aux(Parse_content((Expr this)::Atom(w.ToString())::sl))
           | Parse_string(_, s, sl) ->
               //Buffer.add_char s c;
               s.Append(c) |> ignore;
               aux(Parse_string(false, s, sl))
           end
       | ')' ->
           begin match st with
           | Parse_root sl ->
               failwith "Parsing error: closing parenthesis without openning"
           | Parse_content sl -> (List.rev sl)
           (* | Parse_word(w, sl) -> List.rev(Atom(Buffer.contents w)::sl) *)
           | Parse_word(w, sl) -> List.rev(Atom(w.ToString())::sl)
           | Parse_string(_, s, sl) ->
               (* Buffer.add_char s c; *)
               s.Append(c) |> ignore;
               aux(Parse_string(false, s, sl))
           end
       | ' ' | '\n' | '\r' | '\t' ->
           begin match st with
           | Parse_root sl -> aux(Parse_root sl)
           | Parse_content sl -> aux(Parse_content sl)
           (* | Parse_word(w, sl) -> aux(Parse_content(Atom(Buffer.contents w)::sl)) *)
           | Parse_word(w, sl) -> aux(Parse_content(Atom(w.ToString())::sl))
           | Parse_string(_, s, sl) ->
               //Buffer.add_char s c;
               s.Append(c) |> ignore;
               aux(Parse_string(false, s, sl))
           end
       | '"' ->
           (* '"' *)
           begin match st with
           | Parse_root _ -> failwith "Parse error: double quote at root level"
           | Parse_content sl ->
               (* let s = Buffer.create 74 in *)
               let s = StringBuilder(74) in
               aux(Parse_string(false, s, sl))
           | Parse_word(w, sl) ->
               (* let s = Buffer.create 74 in *)
               let s = StringBuilder(74) in
               (* aux(Parse_string(false, s, Atom(Buffer.contents w)::sl)) *)
               aux(Parse_string(false, s, Atom(w.ToString())::sl))
           | Parse_string(true, s, sl) ->
               (* Buffer.add_char s c; *)
               s.Append(c) |> ignore;
               aux(Parse_string(false, s, sl))
           | Parse_string(false, s, sl) ->
               (* aux(Parse_content(Atom(Buffer.contents s)::sl)) *)
               aux(Parse_content(Atom(s.ToString())::sl))
           end
       | '\\' ->
           begin match st with
           | Parse_string(true, s, sl) ->
               (* Buffer.add_char s c; *)
               s.Append(c) |> ignore;
               aux(Parse_string(false, s, sl))
           | Parse_string(false, s, sl) ->
               aux(Parse_string(true, s, sl))
           | _ ->
               failwith "Parsing error: escape character in wrong place"
           end
       | _ ->
           begin match st with
           | Parse_root _ ->
               failwith(Printf.sprintf "Parsing error: char '%c' at root level" c)
           | Parse_content sl ->
               (* let w = Buffer.create 16 in *)
               let w = StringBuilder(16) in
               (* Buffer.add_char w c; *)
               w.Append(c) |> ignore;
               aux(Parse_word(w, sl))
           | Parse_word(w, sl) ->
               (* Buffer.add_char w c; *)
               w.Append(c) |> ignore;
               aux(Parse_word(w, sl))
           | Parse_string(_, s, sl) ->
               (* Buffer.add_char s c; *)
               s.Append(c) |> ignore;
               aux(Parse_string(false, s, sl))
           end
 in
 aux (Parse_root [])

let string_pop_char str =
 let len = String.length str in
 let i = ref(-1) in
 (function () -> incr i; if !i >= len then None else Some(str.[!i]))

let parse_string str =
 parse (string_pop_char str)

(*
let ic_pop_char ic =
 (function () ->
    try Some(input_char ic)
    with End_of_file -> (None))
*)

let ic_pop_char (ic:TextReader) =
  (function () -> try Some(Convert.ToChar(ic.Read()))
                  with _End_of_file -> (None)
  )

let parse_ic ic =
 parse (ic_pop_char ic)

let parse_file filename =
 (* let ic = open_in filename in *)
 let ic = File.OpenText filename in
 let res = parse_ic ic in
 (* close_in ic; *)
 ic.Close();
 (res)

let quote s =
 "\"" ^ s ^ "\""

let needs_quote s =
 (* List.exists (String.contains s) [' '; '\n'; '\r'; '\t'; '('; ')'] *)
 List.exists (fun elem -> (String.exists (fun c -> c = elem) s)) [' '; '\n'; '\r'; '\t'; '('; ')']

let protect s =
 (* There is no need to "escape" .Net strings the framework takes care of this *)
 (* let s = String.escaped s in *)
 if needs_quote s then quote s else s

let string_of_sexpr s =
 let rec aux acc = function
 | (Atom tag)::tl -> aux ((protect tag)::acc) tl
 | (Expr e)::tl ->
     let s =
       "(" ^
       (String.concat " " (aux [] e))
       ^ ")"
     in
     aux (s::acc) tl
 | [] -> (List.rev acc)
 in
 String.concat " " (aux [] s)

let print_sexpr s =
 (* print_endline (string_of_sexpr s) *)
 printfn "%s" (string_of_sexpr s)

let string_of_sexpr_indent s =
 let rec aux i acc = function
 | (Atom tag)::tl -> aux i ((protect tag)::acc) tl
 | (Expr e)::tl ->
     let s =
       (*
       "\n" ^ (String.make i ' ') ^ "(" ^
       (String.concat " " (aux (succ i) [] e))
       ^ ")"
       *)
       "\n" ^ (String.replicate i " ") ^ "(" ^
       (String.concat " " (aux (i + 1) [] e))
       ^ ")"
     in
     aux i (s::acc) tl
 | [] -> (List.rev acc)
 in
 String.concat "\n" (aux 0 [] s)

let print_sexpr_indent s =
 (* print_endline (string_of_sexpr_indent s) *)
 printfn "%s" (string_of_sexpr_indent s)


vals: []

while [or? 75 > sum vals
            2 > size select vals => [&>=15]] [
    vals: new []

    while [6 > size vals][
        rands: new map 1..4 => [random 1 6]
        remove 'rands .once (min rands)
        'vals ++ sum rands
    ]
]

print ["values:" vals ]
print ["with sum:" sum vals]


100 REM RPG character generator
110 DIM AT(5)
120 DIM AT$(18)
130 AT$="StrDexConIntWisCha"
140 PT=0:SA=0
150 PRINT CHR$(125);CHR$(29);CHR$(31);"Rolling..."
160 FOR AI=0 TO 5
170 DT=0:MI=6:REM dice total, min die
180 FOR I=0 TO 3
190 D=INT(RND(1)*6)+1
200 DT=DT+D
210 IF D<MI THEN MI=D
220 NEXT I
230 DT=DT-MI
240 AT(AI)=DT
250 PT=PT+DT
260 IF DT>=15 THEN SA=SA+1
270 NEXT AI
280 IF PT<75 OR SA<2 THEN 140
290 PRINT CHR$(125);"Character Attributes:"
300 PRINT
310 FOR AI=0 TO 5
315 POSITION 10,AI+2
320 PRINT AT$(AI*3+1,AI*3+3);":";
330 POSITION 16-INT(AT(AI)/10),AI+2
340 PRINT AT(AI)
350 NEXT AI
360 POSITION 8,9
370 PRINT "Total: ";PT
380 PRINT
390 PRINT "Do you accept? ";
400 OPEN #1,4,0,"K:"
410 GET #1,K
420 IF K<>78 AND K<>89 THEN 410
430 PRINT CHR$(K)
440 CLOSE #1
450 IF K=78 THEN 140
460 POSITION 0,13
470 PRINT "Excellent. Good luck on your adventure!"


STRING input := "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW";
STRING output := "12W1B12W3B24W1B14W";

MODE YIELDCHAR = PROC(CHAR)VOID;
MODE GENCHAR = PROC(YIELDCHAR)VOID;

PROC gen char string = (REF STRING s, YIELDCHAR yield)VOID:
  FOR i FROM LWB s TO UPB s DO yield(s[i]) OD;

CO
# Note: The following 2 lines use currying. This not supported by ELLA ALGOL 68RS #
GENCHAR input seq = gen char string(input,),
        output seq = gen char string(output,);
END CO

GENCHAR
  input seq = (YIELDCHAR yield)VOID: gen char string(input, yield),
  output seq = (YIELDCHAR yield)VOID: gen char string(output, yield);

PROC gen encode = (GENCHAR gen char, YIELDCHAR yield)VOID: (
  INT count := 0;
  CHAR prev;
# FOR CHAR c IN # gen char( # ) DO ( #
##   (CHAR c)VOID: (
      IF count = 0 THEN
        count := 1;
        prev := c
      ELIF c NE prev THEN
        STRING str count := whole(count,0);
        gen char string(str count, yield); count := 1;
        yield(prev); prev := c
      ELSE
        count +:=1
      FI
# OD # ));
  IF count NE 0 THEN
    STRING str count := whole(count,0);
    gen char string(str count,yield);
    yield(prev)
  FI
);

STRING zero2nine = "0123456789";

PROC gen decode = (GENCHAR gen char, YIELDCHAR yield)VOID: (
  INT repeat := 0;
# FOR CHAR c IN # gen char( # ) DO ( #
##   (CHAR c)VOID: (
    IF char in string(c, LOC INT, zero2nine) THEN
      repeat := repeat*10 + ABS c - ABS "0"
    ELSE
      FOR i TO repeat DO yield(c) OD;
      repeat := 0
    FI
# OD #  ))
);

# iterate through input string #
print("Encode input: ");
# FOR CHAR c IN # gen encode(input seq, # ) DO ( #
##   (CHAR c)VOID:
    print(c)
# OD # );
print(new line);

# iterate through output string #
print("Decode output: ");
# FOR CHAR c IN # gen decode(output seq, # ) DO ( #
##   (CHAR c)VOID:
    print(c)
# OD # );
print(new line)


USING: formatting kernel math.parser multiline peg peg.ebnf
regexp sequences prettyprint words ;
IN: rosetta-code.s-expressions

STRING: input
((data "quoted data" 123 4.5)
 (data ([email protected]# (4.5) "(more" "data)")))
;

EBNF: sexp>seq [=[
  ws     = [\n\t\r ]* => [[ drop ignore ]]
  digits = [0-9]+
  number = digits => [[ string>number ]]
  float  = digits:a "." digits:b => [[ a b "." glue string>number ]]
  string = '"'~ [^"]* '"'~ => [[ "" like ]]
  symbol = [!#-'*-~]+ => [[ "" like <uninterned-word> ]]
  object = ws ( float | number | string | symbol ) ws
  sexp   = ws "("~ ( object | sexp )* ")"~ ws => [[ { } like ]]
]=]

: seq>sexp ( seq -- str )
    unparse R/ {\s+/ "(" R/ \s+}/ ")" [ re-replace ] [email protected] ;

input [ "Input:\n%s\n\n" printf ] [
    sexp>seq dup seq>sexp
    "Native:\n%u\n\nRound trip:\n%s\n" printf
] bi


package main

import (
    "errors"
    "fmt"
    "reflect"
    "strconv"
    "strings"
    "unicode"
)

var input = `((data "quoted data" 123 4.5)
 (data ([email protected]# (4.5) "(more" "data)")))`

func main() {
    fmt.Println("input:")
    fmt.Println(input)

    s, err := parseSexp(input)
    if err != nil {
        fmt.Println("error:", err)
        return
    }

    fmt.Println("\nparsed:")
    fmt.Println(s)

    fmt.Println("\nrepresentation:")
    s.dump(0)
}

// dynamic types for i are string, qString, int, float64, list, and error.
type sexp struct {
    i interface{}
}
type qString string
type list []sexp

func (s sexp) String() string {
    return fmt.Sprintf("%v", s.i)
}

func (q qString) String() string {
    return strconv.Quote(string(q))
}

func (l list) String() string {
    if len(l) == 0 {
        return "()"
    }
    b := fmt.Sprintf("(%v", l[0])
    for _, s := range l[1:] {
        b = fmt.Sprintf("%s %v", b, s)
    }
    return b + ")"
}

// parseSexp parses a string into a Go representation of an s-expression.
//
// Quoted strings go from one " to the next.  There is no escape character,
// all characters except " are valid.
//
// Otherwise atoms are any string of characters between any of '(', ')',
// '"', or white space characters.  If the atom parses as a Go int type
// using strconv.Atoi, it is taken as int; if it parses as a Go float64
// type using strconv.ParseFloat, it is taken as float64; otherwise it is
// taken as an unquoted string.
//
// Unmatched (, ), or " are errors.
// An empty or all whitespace input string is an error.
// Left over text after the sexp is an error.
//
// An empty list is a valid sexp, but there is no nil, no cons, no dot.
func parseSexp(s string) (sexp, error) {
    s1, rem := ps2(s, -1)
    if err, isErr := s1.i.(error); isErr {
        return sexp{}, err
    }
    if rem > "" {
        return s1, errors.New("Left over text: " + rem)
    }
    return s1, nil
}

// recursive.  n = -1 means not parsing a list.  n >= 0 means the number
// of list elements parsed so far.  string result is unparsed remainder
// of the input string s0.
func ps2(s0 string, n int) (x sexp, rem string) {
    tok, s1 := gettok(s0)
    switch t := tok.(type) {
    case error:
        return sexp{tok}, s1
    case nil: // this is also an error
        if n < 0 {
            return sexp{errors.New("blank input string")}, s0
        } else {
            return sexp{errors.New("unmatched (")}, ""
        }
    case byte:
        switch {
        case t == '(':
            x, s1 = ps2(s1, 0) // x is a list
            if _, isErr := x.i.(error); isErr {
                return x, s0
            }
        case n < 0:
            return sexp{errors.New("unmatched )")}, ""
        default:
            // found end of list.  allocate space for it.
            return sexp{make(list, n)}, s1
        }
    default:
        x = sexp{tok} // x is an atom
    }
    if n < 0 {
        // not in a list, just return the s-expression x
        return x, s1
    }
    // in a list.  hold on to x while we parse the rest of the list.
    l, s1 := ps2(s1, n+1)
    // result l is either an error or the allocated list, not completely
    // filled in yet.
    if _, isErr := l.i.(error); !isErr {
        // as long as no errors, drop x into its place in the list
        l.i.(list)[n] = x
    }
    return l, s1
}

// gettok gets one token from string s.
// return values are the token and the remainder of the string.
// dynamic type of tok indicates result:
// nil:  no token.  string was empty or all white space.
// byte:  one of '(' or ')'
// otherwise string, qString, int, float64, or error.
func gettok(s string) (tok interface{}, rem string) {
    s = strings.TrimSpace(s)
    if s == "" {
        return nil, ""
    }
    switch s[0] {
    case '(', ')':
        return s[0], s[1:]
    case '"':
        if i := strings.Index(s[1:], `"`); i >= 0 {
            return qString(s[1 : i+1]), s[i+2:]
        }
        return errors.New(`unmatched "`), s
    }
    i := 1
    for i < len(s) && s[i] != '(' && s[i] != ')' && s[i] != '"' &&
        !unicode.IsSpace(rune(s[i])) {
        i++
    }
    if j, err := strconv.Atoi(s[:i]); err == nil {
        return j, s[i:]
    }
    if f, err := strconv.ParseFloat(s[:i], 64); err == nil {
        return f, s[i:]
    }
    return s[:i], s[i:]
}

func (s sexp) dump(i int) {
    fmt.Printf("%*s%v: ", i*3, "", reflect.TypeOf(s.i))
    if l, isList := s.i.(list); isList {
        fmt.Println(len(l), "elements")
        for _, e := range l {
            e.dump(i + 1)
        }
    } else {
        fmt.Println(s.i)
    }
}


function min(a, b)
	if a < b then return a else return b
end function

function d6()
	#simulates a marked regular hexahedron coming to rest on a plane
	return  1 + int(rand * 6)
end function

function roll_stat()
	#rolls four dice, returns the sum of the three highest
	a = d6() : b = d6() : c = d6() : d = d6()
	return a + b + c + d - min(min(a, b), min(c, d))
end function

arraybase 1
dim statnames$ = {"STR", "CON", "DEX", "INT", "WIS", "CHA"}
dim stat(6)
acceptable = false

do
	sum = 0 : n15 = 0
	for i = 1 to 6
		stat[i] = roll_stat()
		sum += stat[i]
		if stat[i] >= 15 then n15 += 1
	next i
	if sum >= 75 and n15 >= 2 then acceptable = true
until acceptable

for i = 1 to 6
	print statnames$[i]; ": "; stat[i]
next i
print "-------"
print "TOT: "; sum
end


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

int compareInts(const void *i1, const void *i2) {
    int a = *((int *)i1);
    int b = *((int *)i2);
    return a - b;
}

int main() {
    int i, j, nsum, vsum, vcount, values[6], numbers[4];
    srand(time(NULL));
    for (;;) {
        vsum = 0;
        for (i = 0; i < 6; ++i) {
            for (j = 0; j < 4; ++j) {
                numbers[j] = 1 + rand() % 6;
            }
            qsort(numbers, 4, sizeof(int), compareInts);
            nsum = 0;
            for (j = 1; j < 4; ++j) {
                nsum += numbers[j];
            }
            values[i] = nsum;
            vsum += values[i];
        }
        if (vsum < 75) continue;
        vcount = 0;
        for (j = 0; j < 6; ++j) {
            if (values[j] >= 15) vcount++;
        }
        if (vcount < 2) continue;
        printf("The 6 random numbers generated are:\n");
        printf("[");
        for (j = 0; j < 6; ++j) printf("%d ", values[j]);
        printf("\b]\n");
        printf("\nTheir sum is %d and %d of them are >= 15\n", vsum, vcount);
        break;
    }
    return 0;
}


    ∇ ret←RLL rll;count
[1]   count←∣2-/((1,(2≠/rll),1)×⍳1+⍴rll)~0
[2]   ret←(⍕count,¨(1,2≠/rll)/rll)~' '
    ∇


------------------ RUN-LENGTH ENCODING -----------------

-- encode :: String -> String
on encode(s)
    script go
        on |λ|(cs)
            if {} ≠ cs then
                set c to text 1 of cs
                set {chunk, residue} to span(eq(c), rest of cs)
                (c & (1 + (length of chunk)) as string) & |λ|(residue)
            else
                ""
            end if
        end |λ|
    end script
    |λ|(characters of s) of go
end encode

-- decode :: String -> String
on decode(s)
    script go
        on |λ|(cs)
            if {} ≠ cs then
                set {ds, residue} to span(my isDigit, rest of cs)
                set n to (ds as string) as integer
                replicate(n, item 1 of cs) & |λ|(residue)
            else
                ""
            end if
        end |λ|
    end script
    |λ|(characters of s) of go
end decode

--------------------------- TEST -------------------------
on run
    set src to ¬
        "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"
    set encoded to encode(src)
    set decoded to decode(encoded)

    unlines({encoded, decoded, src = decoded})
end run

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

-- eq :: a -> a -> Bool
on eq(a)
    -- True if a and b are equivalent in terms
    -- of the AppleScript (=) operator.
    script go
        on |λ|(b)
            a = b
        end |λ|
    end script
end eq

-- isDigit :: Char -> Bool
on isDigit(c)
    set n to (id of c)
    48 ≤ n and 57 ≥ n
end isDigit

-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
    -- 2nd class handler function lifted into 1st class script wrapper.
    if script is class of f then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn

-- Egyptian multiplication - progressively doubling a list, appending
-- stages of doubling to an accumulator where needed for binary
-- assembly of a target length
-- replicate :: Int -> String -> String
on replicate(n, s)
    -- Egyptian multiplication - progressively doubling a list,
    -- appending stages of doubling to an accumulator where needed
    -- for binary assembly of a target length
    script p
        on |λ|({n})
            n ≤ 1
        end |λ|
    end script

    script f
        on |λ|({n, dbl, out})
            if (n mod 2) > 0 then
                set d to out & dbl
            else
                set d to out
            end if
            {n div 2, dbl & dbl, d}
        end |λ|
    end script

    set xs to |until|(p, f, {n, s, ""})
    item 2 of xs & item 3 of xs
end replicate

-- span :: (a -> Bool) -> [a] -> ([a], [a])
on span(p, xs)
    -- The longest (possibly empty) prefix of xs
    -- that contains only elements satisfying p,
    -- tupled with the remainder of xs.
    -- span(p, xs) eq (takeWhile(p, xs), dropWhile(p, xs))
    script go
        property mp : mReturn(p)
        on |λ|(vs)
            if {} ≠ vs then
                set x to item 1 of vs
                if |λ|(x) of mp then
                    set {ys, zs} to |λ|(rest of vs)
                    {{x} & ys, zs}
                else
                    {{}, vs}
                end if
            else
                {{}, {}}
            end if
        end |λ|
    end script
    |λ|(xs) of go
end span

-- unlines :: [String] -> String
on unlines(xs)
    -- A single string formed by the intercalation
    -- of a list of strings with the newline character.
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, linefeed}
    set s to xs as text
    set my text item delimiters to dlm
    s
end unlines

-- until :: (a -> Bool) -> (a -> a) -> a -> a
on |until|(p, f, x)
    set v to x
    set mp to mReturn(p)
    set mf to mReturn(f)
    repeat until mp's |λ|(v)
        set v to mf's |λ|(v)
    end repeat
    v
end |until|


import qualified Data.Functor.Identity as F
import qualified Text.Parsec.Prim as Prim
import Text.Parsec
       ((<|>), (<?>), many, many1, char, try, parse, sepBy, choice,
        between)
import Text.Parsec.Token
       (integer, float, whiteSpace, stringLiteral, makeTokenParser)
import Text.Parsec.Char (noneOf)
import Text.Parsec.Language (haskell)

data Val
  = Int Integer
  | Float Double
  | String String
  | Symbol String
  | List [Val]
  deriving (Eq, Show)

tProg :: Prim.ParsecT String a F.Identity [Val]
tProg = many tExpr <?> "program"
  where
    tExpr = between ws ws (tList <|> tAtom) <?> "expression"
    ws = whiteSpace haskell
    tAtom =
      (try (Float <$> float haskell) <?> "floating point number") <|>
      (try (Int <$> integer haskell) <?> "integer") <|>
      (String <$> stringLiteral haskell <?> "string") <|>
      (Symbol <$> many1 (noneOf "()\"\t\n\r ") <?> "symbol") <?>
      "atomic expression"
    tList = List <$> between (char '(') (char ')') (many tExpr) <?> "list"

p :: String -> IO ()
p = either print (putStrLn . unwords . map show) . parse tProg ""

main :: IO ()
main = do
  let expr =
        "((data \"quoted data\" 123 4.5)\n  (data ([email protected]# (4.5) \"(more\" \"data)\")))"
  putStrLn ("The input:\n" ++ expr ++ "\n\nParsed as:")
  p expr


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

static class Module1
{
    static Random r = new Random();

    static List<int> getThree(int n)
    {
        List<int> g3 = new List<int>();
        for (int i = 0; i < 4; i++) g3.Add(r.Next(n) + 1);
        g3.Sort(); g3.RemoveAt(0); return g3;
    }

    static List<int> getSix()
    {
        List<int> g6 = new List<int>();
        for (int i = 0; i < 6; i++) g6.Add(getThree(6).Sum());
        return g6;
    }

    static void Main(string[] args)
    {
        bool good = false; do {
            List<int> gs = getSix(); int gss = gs.Sum(); int hvc = gs.FindAll(x => x > 14).Count;
            Console.Write("attribs: {0}, sum={1}, ({2} sum, high vals={3})",
                          string.Join(", ", gs), gss, gss >= 75 ? "good" : "low", hvc);
            Console.WriteLine(" - {0}", (good = gs.Sum() >= 75 && hvc > 1) ? "success" : "failure");
        } while (!good);
    }
}


runlengthEncode: function [s][
    join map chunk split s => [&] 'x ->
        (to :string size x) ++ first x
]

runlengthDecode: function [s][
    result: new ""
    loop (chunk split s 'x -> positive? size match x {/\d+/}) [a,b] ->
        'result ++ repeat first b to :integer join to [:string] a
    return result
]

str: "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"

encoded: runlengthEncode str
print ["encoded:" encoded]

decoded: runlengthDecode encoded
print ["decoded:" decoded]

if decoded=str -> print "\nSuccess!"


MsgBox % key := rle_encode("WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW")
MsgBox % rle_decode(key)

rle_encode(message)
{
  StringLeft, previous, message, 1
  StringRight, last, message, 1
  message .= Asc(Chr(last)+1)
  count = 0
  Loop, Parse, message
  {
    If (previous == A_LoopField)
      count +=1
    Else
    {
      output .= previous . count
      previous := A_LoopField
      count = 1
    }
  }
  Return output
}

rle_decode(message)
{
  pos = 1
  While, item := RegExMatch(message, "\D", char, pos)
  {
    digpos := RegExMatch(message, "\d+", dig, item)
    Loop, % dig
      output .= char
    pos := digpos
  }
  Return output
}


link ximage

procedure main()
  in := "((data 'quoted data' 123 4.5) (data ([email protected]# (4.5) '(more' 'data)')))"
  # in := map(in,"'","\"") # uncomment to put back double quotes if desired
  write("Input:  ",image(in))
  write("Structure: \n",ximage(S := string2sexp(in)))
  write("Output:  ",image(sexp2string(S)))
end

procedure sexp2string(S)   #: return a string representing the s-expr
   s := ""
   every t := !S do {
      if type(t) == "list" then
         s ||:= "(" || trim(sexp2string(t)) || ")"
      else
         if upto('() \t\r\n',t) then
            s ||:= "'" || t || "'"
         else
            s ||:= t
      s ||:= " "
      }
   return trim(s)
end

procedure string2sexp(s)   #: return a s-expression nested list
   if s ? ( sexptokenize(T := []), pos(0) ) then
      return sexpnest(T)
   else
      write("Malformed: ",s)
end

procedure sexpnest(T,L)   #: transform s-expr token list to nested list
   /L := []
   while t := get(T) do
      case t of {
         "("      :  {
                     put(L,[])
                     sexpnest(T,L[*L])
                     }
         ")"      :  return L
         default  :  put(L, numeric(t) | t)
      }
      return L
end

procedure sexptokenize(T) #: return list of tokens parsed from an s-expr string
static sym
initial sym := &letters++&digits++'~`[email protected]#$%^&*_-+|;:.,<>[]{}'
   until pos(0) do
      case &subject[&pos] of {
         " "   :  tab(many(' \t\r\n'))                     # consume whitespace
         "'"|"\""  :
            (q := move(1)) & put(T,tab(find(q))) & move(1) # quotes
         "("   :  put(T,move(1)) & sexptokenize(T)         # open
         ")"   :  put(T,move(1)) &return T                 # close
         default  : put(T, tab(many(sym)))                 # other symbols
         }
   return T
end


#include <algorithm>
#include <ctime>
#include <iostream>
#include <cstdlib>
#include <string>

using namespace std;

int main()
{
    srand(time(0));

    unsigned int attributes_total = 0;
    unsigned int count = 0;
    int attributes[6] = {};
    int rolls[4] = {};

    while(attributes_total < 75 || count < 2)
    {
        attributes_total = 0;
        count = 0;

        for(int attrib = 0; attrib < 6; attrib++)
        {
            for(int roll = 0; roll < 4; roll++)
            {
                rolls[roll] = 1 + (rand() % 6);
            }

            sort(rolls, rolls + 4);
            int roll_total = rolls[1] + rolls[2] + rolls[3];

            attributes[attrib] = roll_total;
            attributes_total += roll_total;

            if(roll_total >= 15) count++;
        }
    }

    cout << "Attributes generated : [";
    cout << attributes[0] << ", ";
    cout << attributes[1] << ", ";
    cout << attributes[2] << ", ";
    cout << attributes[3] << ", ";
    cout << attributes[4] << ", ";
    cout << attributes[5];

    cout << "]\nTotal: " << attributes_total;
    cout << ", Values above 15 : " << count;

    return 0;
}


FUNCTION Rle_Encode$(txt$)

    LOCAL result$, c$ = LEFT$(txt$, 1)
    LOCAL total = 1

    FOR x = 2 TO LEN(txt$)
        IF c$ = MID$(txt$, x, 1) THEN
            INCR total
        ELSE
            result$ = result$ & STR$(total) & c$
            c$ = MID$(txt$, x, 1)
            total = 1
        END IF
    NEXT

    RETURN result$ & STR$(total) & c$

END FUNCTION

FUNCTION Rle_Decode$(txt$)

    LOCAL nr$, result$

    FOR x = 1 TO LEN(txt$)
        IF REGEX(MID$(txt$, x, 1), "[[:digit:]]") THEN
            nr$ = nr$ & MID$(txt$, x, 1)
        ELSE
            result$ = result$ & FILL$(VAL(nr$), ASC(MID$(txt$, x, 1)))
            nr$ = ""
        END IF
    NEXT

    RETURN result$

END FUNCTION

rle_data$ = "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"

PRINT "RLEData: ", rle_data$
encoded$ = Rle_Encode$(rle_data$)
PRINT "Encoded: ", encoded$
PRINT "Decoded: ", Rle_Decode$(encoded$)


NB. character classes: 0: paren, 1: quote, 2: whitespace, 3: wordforming (default)
chrMap=: '()';'"';' ',LF,TAB,CR

NB. state columns correspond to the above character classes
NB. first digit chooses next state.
NB. second digit is action 0: do nothing, 1: start token, 2: end token
states=: 10 10#: ".;._2]0 :0
  11  21  00  31  NB. state 0: initial state
  12  22  02  32  NB. state 1: after () or after closing "
  40  10  40  40  NB. state 2: after opening "
  12  22  02  30  NB. state 3: after word forming character
  40  10  40  40  NB. state 4: between opening " and closing "
)

tokenize=: (0;states;<chrMap)&;:

rdSexpr=:3 :0 :.wrSexpr
  s=. r=. '' [ 'L R'=. ;:'()'
  for_token. tokenize y do.
    select. token
      case. L do. r=. ''  [ s=. s,<r
      case. R do. s=. }:s [ r=. (_1{::s),<r
      case.   do. r=. r,token
    end.
  end.
  >{.r
)

wrSexpr=: ('(' , ;:^:_1 , ')'"_)^:L.L:1^:L. :.rdSexpr

fmt=: 3 :0 :.unfmt
  if. '"' e. {.y     do. }.,}: y  NB. quoted string
  elseif. 0=#$n=.".y do. n        NB. number or character
  elseif.            do. s:<y     NB. symbol
  end.
)

unfmt=: 3 :0 :.fmt
  select. 3!:0 y
    case. 1;4;8;16;128 do. ":!.20 y
    case. 2;131072     do.
      select. #$y
        case. 0 do. '''',y,''''
        case. 1 do. '"',y,'"'
      end.
    case. 64           do. (":y),'x'
    case. 65536        do. >s:inv y
  end.
)

readSexpr=: fmt L:0 @rdSexpr :.writeSexpr
writeSexpr=: wrSexpr @(unfmt L:0) :.readSexpr


RPGGEN
    set attr = $lb("")    ; empty list to start
    write "Rules:",!,"1.) Total of 6 attributes must be at least 75.",!,"2.) At least two scores must be 15 or more.",!

    ; loop until valid result
    do {
        ; loop through 6 attributes
        for i = 1:1:6 {
            set (low, dice, keep) = ""

            ; roll 4 dice each time
            for j = 1:1:4 {
                set roll = $r(6) + 1
                set dice = dice + roll

                if (roll < low) || (low = "") {
                    set low = roll
                }
            }    ; 4 dice rolls per attribute

            set keep = (dice - low)
            set $list(attr,i) = keep
        }    ; 6 attributes

        ; loop the ending list
        set (tot,bigs) = 0
        for i = 1:1:$listlength(attr) {
            set cur = $listget(attr,i)
            set tot = tot + cur

            if (cur >= 15) {
                set bigs = bigs + 1
            }
        }

        ; analyze results
        write !,"Scores: "_$lts(attr)
        set result = $select((tot < 75) && (bigs < 2):0,tot < 75:1,bigs < 2:2,1:3)
        write !,?5,$case(result,
                    0:"Total "_tot_" too small and not enough attributes ("_bigs_") >= 15.",
                    1:"Total "_tot_" too small.",
                    2:"Need 2 or more attributes >= 15, only have "_bigs_".",
                    3:"Total "_tot_" and "_bigs_ " attributes >=15 are sufficient.")
    } while (result '= 3)

    quit


% This program needs to be merged with PCLU's "misc" library
% to use the random number generator.
%
% pclu -merge $CLUHOME/lib/misc.lib -compile rpg_gen.clu

% Seed the random number generator with the current time
init_rng = proc ()
    d: date := now()
    seed: int := ((d.hour*60) + d.minute)*60 + d.second
    random$seed(seed)
end init_rng

character = cluster is generate
    rep = null

    % Roll a die
    roll_die = proc () returns (int)
        return (1 + random$next(6))
    end roll_die

    % Roll four dice and get the sum of the highest three rolls
    roll_four_times = proc () returns (int)
        lowest: int := 7 % higher than any dice roll
        sum: int := 0
        for i: int in int$from_to(1,4) do
            roll: int := roll_die()
            sum := sum + roll
            if roll < lowest then lowest := roll end
        end
        return (sum - lowest)
    end roll_four_times

    % Try to generate a character by rolling six values
    try_generate = proc () returns (sequence[int])
        rolls: sequence[int] := sequence[int]$[]
        for i: int in int$from_to(1,6) do
            rolls := sequence[int]$addh(rolls, roll_four_times())
        end
        return (rolls)
    end try_generate

    % See if a character is valid
    valid = proc (c: sequence[int]) returns (bool)
        total: int := 0
        at_least_15: int := 0
        for i: int in sequence[int]$elements(c) do
            total := total + i
            if i >= 15 then at_least_15 := at_least_15 + 1 end
        end
        return (total >= 75 & at_least_15 >= 2)
    end valid

    % Generate a character
    generate = proc () returns (sequence[int])
        while true do
            c: sequence[int] := try_generate()
            if valid(c) then return(c) end
        end
    end generate
end character

% Generate a character and display the six values
start_up = proc ()
    po: stream := stream$primary_output()
    init_rng()
    hero: sequence[int] := character$generate()
    for stat: int in sequence[int]$elements(hero) do
        stream$putright(po, int$unparse(stat), 4)
    end
end start_up


100 rem rpg character roller
110 rem rosetta code - commodore basic
120 dim di(3):rem dice
130 dim at(5),at$(5):rem attributes as follows:
140 at$(0)="Strength"
150 at$(1)="Dexterity"
160 at$(2)="Constitution"
170 at$(3)="Intelligence"
180 at$(4)="Wisdom"
190 at$(5)="Charisma"
200 pt=0:sa=0:rem points total and number of strong attributes (15+)
210 print chr$(147);chr$(14);chr$(29);chr$(17);"Rolling..."
220 for ai=0 to 5:rem attribute index
230 for i=0 to 3:di(i)=int(rnd(.)*6)+1:next i
240 gosub 450
250 dt=0:rem dice total
260 for i=0 to 2:dt=dt+di(i):next i:rem take top 3
270 at(ai)=dt:pt=pt+dt
280 if dt>=15 then sa=sa+1
290 next ai
300 if pt<75 or sa<2 then goto 200
310 print chr$(147);"Character Attributes:"
320 print
330 for ai=0 to 5
340 print spc(13-len(at$(ai)));at$(ai);":";tab(14);at(ai)
350 next ai
360 print
370 print "        Total:";tab(14);pt
380 print
390 print "Do you accept? ";
400 get k$:if k$<>"y" and k$<>"n" then 400
410 print k$
420 if k$="n" then goto 200
430 print:print "Excellent. Good luck on your adventure!"
440 end
450 rem "sort" dice - really just put smallest one last
460 for x=0 to 2
470 if di(x)<di(x+1) then t=di(x):di(x)=di(x+1):di(x+1)=t
480 next x
490 return


DECLARE FUNCTION RLDecode$ (i AS STRING)
DECLARE FUNCTION RLEncode$ (i AS STRING)

DIM initial AS STRING, encoded AS STRING, decoded AS STRING

INPUT "Type something: ", initial
encoded = RLEncode(initial)
decoded = RLDecode(encoded)
PRINT initial
PRINT encoded
PRINT decoded

FUNCTION RLDecode$ (i AS STRING)
    DIM Loop0 AS LONG, rCount AS STRING, outP AS STRING, m AS STRING

    FOR Loop0 = 1 TO LEN(i)
        m = MID$(i, Loop0, 1)
        SELECT CASE m
            CASE "0" TO "9"
                rCount = rCount + m
            CASE ELSE
                IF LEN(rCount) THEN
                    outP = outP + STRING$(VAL(rCount), m)
                    rCount = ""
                ELSE
                    outP = outP + m
                END IF
        END SELECT
    NEXT
    RLDecode$ = outP
END FUNCTION

FUNCTION RLEncode$ (i AS STRING)
    DIM tmp1 AS STRING, tmp2 AS STRING, outP AS STRING
    DIM Loop0 AS LONG, rCount AS LONG

    tmp1 = MID$(i, 1, 1)
    tmp2 = tmp1
    rCount = 1

    FOR Loop0 = 2 TO LEN(i)
        tmp1 = MID$(i, Loop0, 1)
        IF tmp1 <> tmp2 THEN
            outP = outP + LTRIM$(RTRIM$(STR$(rCount))) + tmp2
            tmp2 = tmp1
            rCount = 1
        ELSE
            rCount = rCount + 1
        END IF
    NEXT

    outP = outP + LTRIM$(RTRIM$(STR$(rCount)))
    outP = outP + tmp2
    RLEncode$ = outP
END FUNCTION


package jfkbits;

import java.io.BufferedReader;
import java.io.IOException;
import java.io.Reader;
import java.io.StreamTokenizer;
import java.io.StringReader;
import java.util.Iterator;

public class LispTokenizer implements Iterator<Token>
{
    // Instance variables have default access to allow unit tests access.
    StreamTokenizer m_tokenizer;
    IOException m_ioexn;

    /** Constructs a tokenizer that scans input from the given string.
     * @param src A string containing S-expressions.
     */
    public LispTokenizer(String src)
    {
        this(new StringReader(src));
    }

    /** Constructs a tokenizer that scans input from the given Reader.
     * @param r Reader for the character input source
     */
    public LispTokenizer(Reader r)
    {
        if(r == null)
            r = new StringReader("");
        BufferedReader buffrdr = new BufferedReader(r);
        m_tokenizer = new StreamTokenizer(buffrdr);
        m_tokenizer.resetSyntax(); // We don't like the default settings

        m_tokenizer.whitespaceChars(0, ' ');
        m_tokenizer.wordChars(' '+1,255);
        m_tokenizer.ordinaryChar('(');
        m_tokenizer.ordinaryChar(')');
        m_tokenizer.ordinaryChar('\'');
        m_tokenizer.commentChar(';');
        m_tokenizer.quoteChar('"');
    }

    public Token peekToken()
    {
        if(m_ioexn != null)
            return null;
        try
        {
            m_tokenizer.nextToken();
        }
        catch(IOException e)
        {
            m_ioexn = e;
            return null;
        }
        if(m_tokenizer.ttype == StreamTokenizer.TT_EOF)
            return null;
        Token token = new Token(m_tokenizer);
        m_tokenizer.pushBack();
        return token;
    }

    public boolean hasNext()
    {
        if(m_ioexn != null)
            return false;
        try
        {
            m_tokenizer.nextToken();
        }
        catch(IOException e)
        {
            m_ioexn = e;
            return false;
        }
        if(m_tokenizer.ttype == StreamTokenizer.TT_EOF)
            return false;
        m_tokenizer.pushBack();
        return true;
    }

    /** Return the most recently caught IOException, if any,
     *
     * @return
     */
    public IOException getIOException()
    {
        return m_ioexn;
    }

    public Token next()
    {
        try
        {
            m_tokenizer.nextToken();
        }
        catch(IOException e)
        {
            m_ioexn = e;
            return null;
        }

        Token token = new Token(m_tokenizer);
        return token;
    }

    public void remove()
    {
    }
}


(defpackage :rpg-generator
  (:use :cl)
  (:export :generate))
(in-package :rpg-generator)
(defun sufficient-scores-p (scores)
  (and (>= (apply #'+ scores) 75)
       (>= (count-if #'(lambda (n) (>= n 15)) scores) 2)))

(defun gen-score ()
  (apply #'+ (rest (sort (loop repeat 4 collect (1+ (random 6))) #'<))))

(defun generate ()
  (loop for scores = (loop repeat 6 collect (gen-score))
        until (sufficient-scores-p scores)
        finally (format t "Scores: ~A~%" scores)
                (format t "Total: ~A~%" (apply #'+ scores))
                (format t ">= 15: ~A~%" (count-if (lambda (n) (>= n 15)) scores))
                (return scores)))


include "cowgol.coh";
include "argv.coh";

# There is no random number generator in the standard library (yet?)
# There is also no canonical source of randomness, and indeed,
# on some target platforms (like CP/M) there is no guaranteed
# source of randomness at all. Therefore, I implement the "X ABC"
# random number generator, and ask for a seed on the command line.

record RandState is
    x @at(0): uint8;
    a @at(1): uint8;
    b @at(2): uint8;
    c @at(3): uint8;
end record;

sub RandByte(s: [RandState]): (r: uint8) is
    s.x := s.x + 1;
    s.a := s.a ^ s.c ^ s.x;
    s.b := s.b + s.a;
    s.c := s.c + (s.b >> 1) ^ s.a;
    r := s.c;
end sub;

# Roll a d6
typedef D6 is int(1, 6);
sub Roll(s: [RandState]): (r: D6) is
    var x: uint8;
    loop
        x := RandByte(s) & 7;
        if x < 6 then break; end if;
    end loop;
    r := x + 1;
end sub;

# Roll 4 D6es and get the sum of the 3 highest
sub Roll4(s: [RandState]): (r: uint8) is
    r := 0;
    var lowest: uint8 := 0;
    var n: uint8 := 4;
    while n > 0 loop
        var roll := Roll(s);
        r := r + roll;
        if lowest > roll then
            lowest := roll;
        end if;
        n := n - 1;
    end loop;
    r := r - lowest;
end sub;

# Read random seed from command line
var randState: RandState;

ArgvInit();
var argmt := ArgvNext();
if argmt == (0 as [uint8]) then
    print("Please give random seed on command line.\n");
    ExitWithError();
end if;
([&randState as [int32]], argmt) := AToI(argmt);

var total: uint8;
var attrs: uint8[6];
var i: @indexof attrs;
loop
    var at15: uint8 := 0;
    i := 0;
    total := 0;

    # generate 6 attributes
    while i < 6 loop
        attrs[i] := Roll4(&randState);
        total := total + attrs[i];
        # count how many are higher than or equal to 15
        if attrs[i] >= 15 then
            at15 := at15 + 1;
        end if;
        i := i + 1;
    end loop;

    # if the requirements are met, then stop
    if total >= 75 and at15 >= 2 then
        break;
    end if;
end loop;

# Show the generated values
print("Attributes: ");
i := 0;
while i < 6 loop
    print_i8(attrs[i]);
    print_char(' ');
    i := i + 1;
end loop;
print("\nTotal: ");
print_i8(total);
print_nl();


function FBString(lon, cad$)
	# Definimos la función String en BASIC256
	cadena$ = ""
	for a = 1 to lon
		cadena$ += cad$
	next a
	return cadena$
end function

function RLDecode(i$)
	rCount$ = "" : outP$ = ""

	for Loop0 = 1 to length(i$)
		m$ = mid(i$, Loop0, 1)
		begin case
			case m$ = "0"
				rCount$ += m$
			case m$ = "1"
				rCount$ += m$
			case m$ = "2"
				rCount$ += m$
			case m$ = "3"
				rCount$ += m$
			case m$ = "4"
				rCount$ += m$
			case m$ = "5"
				rCount$ += m$
			case m$ = "6"
				rCount$ += m$
			case m$ = "7"
				rCount$ += m$
			case m$ = "8"
				rCount$ += m$
			case m$ = "9"
				rCount$ += m$
			else
				if length(rCount$) then
					outP$ += FBString(int(rCount$), m$)
					rCount$ = ""
				else
					outP$ += m$
				end if
		end case
	next Loop0

	RLDecode = outP$
end function

function RLEncode(i$)
	outP$ = ""
	tmp1 = mid(i$, 1, 1)
	tmp2 = tmp1
	rCount = 1

	for Loop0 = 2 to length(i$)
		tmp1 = mid(i$, Loop0, 1)
		if tmp1 <> tmp2 then
			outP$ += string(rCount) + tmp2
			tmp2 = tmp1
			rCount = 1
		else
			rCount += 1
		end if
	next Loop0

	outP$ += replace(string(rCount)," ", "")
	outP$ += tmp2
	RLEncode = outP$
end function

input "Type something: ", initial
encoded$ = RLEncode(initial)
decoded$ = RLDecode(encoded$)
print initial
print encoded$
print decoded$
end


      input$ = "WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW"
      PRINT "Input:  " input$
      rle$ = FNencodeRLE(input$)
      output$ = FNdecodeRLE(rle$)
      PRINT "Output: " output$
      END

      DEF FNencodeRLE(text$)
      LOCAL n%, r%, c$, o$
      n% = 1
      WHILE n% <= LEN(text$)
        c$ = MID$(text$, n%, 1)
        n% += 1
        r% = 1
        WHILE c$ = MID$(text$, n%, 1) AND r% < 127
          r% += 1
          n% += 1
        ENDWHILE
        IF r% < 3 o$ += STRING$(r%, c$) ELSE o$ += CHR$(128+r%) + c$
      ENDWHILE
      = o$

      DEF FNdecodeRLE(rle$)
      LOCAL n%, c$, o$
      n% = 1
      WHILE n% <= LEN(rle$)
        c$ = MID$(rle$, n%, 1)
        n% += 1
        IF ASC(c$) > 128 THEN
          o$ += STRING$(ASC(c$)-128, MID$(rle$, n%, 1))
          n% += 1
        ELSE
          o$ += c$
        ENDIF
      ENDWHILE
      = o$


String.prototype.parseSexpr = function() {
	var t = this.match(/\s*("[^"]*"|\(|\)|"|[^\s()"]+)/g)
	for (var o, c=0, i=t.length-1; i>=0; i--) {
		var n, ti = t[i].trim()
		if (ti == '"') return
		else if (ti == '(') t[i]='[', c+=1
		else if (ti == ')') t[i]=']', c-=1
		else if ((n=+ti) == ti) t[i]=n
		else t[i] = '\'' + ti.replace('\'', '\\\'') + '\''
		if (i>0 && ti!=']' && t[i-1].trim()!='(' ) t.splice(i,0, ',')
		if (!c) if (!o) o=true; else return
	}
	return c ? undefined : eval(t.join(''))
}

Array.prototype.toString = function() {
	var s=''; for (var i=0, e=this.length; i<e; i++) s+=(s?' ':'')+this[i]
	return '('+s+')'
}

Array.prototype.toPretty = function(s) {
	if (!s) s = ''
	var r = s + '(
'
	var s2 = s + Array(6).join(' ')
	for (var i=0, e=this.length; i<e; i+=1) {
		var ai = this[i]
		r += ai.constructor != Array ? s2+ai+'
' : ai.toPretty(s2)
	}
	return r + s + ')
'
}

var str = '((data "quoted data" 123 4.5)\n (data ([email protected]# (4.5) "(more" "data)")))'
document.write('text:
', str.replace(/\n/g,'
').replace(/ /g,' '), '

')
var sexpr = str.parseSexpr()
if (sexpr === undefined)
	document.write('Invalid s-expr!', '
')
else
	document.write('s-expr:
', sexpr, '

', sexpr.constructor != Array ? '' : 'pretty print:
' + sexpr.toPretty())


def roll_stat
  dices = Array(Int32).new(4) { rand(1..6) }
  dices.sum - dices.min
end

def roll_character
  loop do
    stats = Array(Int32).new(6) { roll_stat }
    return stats if stats.sum >= 75 && stats.count(&.>=(15)) >= 2
  end
end

10.times do
  stats = roll_character
  puts "stats: #{stats}, sum is #{stats.sum}"
end


program RPG_Attributes_Generator;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  System.Generics.Collections;

type
  TListOfInt = class(TList<Integer>)
  public
    function Sum: Integer;
    function FindAll(func: Tfunc<Integer, Boolean>): TListOfInt;
    function Join(const sep: string): string;
  end;

{ TListOfInt }

function TListOfInt.FindAll(func: Tfunc<Integer, Boolean>): TListOfInt;
var
  Item: Integer;
begin
  Result := TListOfInt.Create;
  if Assigned(func) then
    for Item in self do
      if func(Item) then
        Result.Add(Item);
end;

function TListOfInt.Join(const sep: string): string;
var
  Item: Integer;
begin
  Result := '';
  for Item in self do
    if Result.IsEmpty then
      Result := Item.ToString
    else
      Result := Result + sep + Item.ToString;
end;

function TListOfInt.Sum: Integer;
var
  Item: Integer;
begin
  Result := 0;
  for Item in self do
    Inc(Result, Item);
end;

function GetThree(n: integer): TListOfInt;
var
  i: Integer;
begin
  Randomize;
  Result := TListOfInt.Create;
  for i := 0 to 3 do
    Result.Add(Random(n) + 1);
  Result.Sort;
  Result.Delete(0);
end;

function GetSix(): TListOfInt;
var
  i: Integer;
  tmp: TListOfInt;
begin
  Result := TListOfInt.Create;
  for i := 0 to 5 do
  begin
    tmp := GetThree(6);
    Result.Add(tmp.Sum);
    tmp.Free;
  end;
end;

const
  GOOD_STR: array[Boolean] of string = ('low', 'good');
  SUCCESS_STR: array[Boolean] of string = ('failure', 'success');

var
  good: Boolean;
  gs, hvcList: TListOfInt;
  gss, hvc: Integer;

begin
  good := false;
    repeat
    gs := GetSix();
    gss := gs.Sum;

    hvcList := gs.FindAll(
      function(x: Integer): Boolean
      begin
        result := x > 14;
      end);
    hvc := hvcList.Count;
    hvcList.Free;

    Write(Format('Attribs: %s, sum=%d, (%s sum, high vals=%d)', [gs.Join(', '),
      gss, GOOD_STR[gss >= 75], hvc]));

    good := (gss >= 75) and (hvc > 1);

    Writeln(' - ', SUCCESS_STR[good]);

    gs.Free;
  until good;
  Readln;
end.


                    ~"y"- ~$         v
  <temp var for when char changes
format:
first,'n' and a newline.             :
a char then a                   v    _"n",v
number then a space continuously          9
example:                                  1
n                               >    v  ,+<
a5 b2
decoded:aaaaabb
the program is ended using   decoder
Ctrl-C on linux,or alt-f4
on windows.copy the output    >\v       encoder
of the program somewhere      ^_ $ v
to encode press y              :        > $11g:,  v
to decode pipe file in      >1-^   ~       v  +1\<
the output of the encoder   \  v<  $    ^     .\_^
starts with n,this is so    ^,:<\&~< _~:,>1>\:v>^
you can pipe it straight in              ^        <
                                              ~
the spaces seem to be a annoying thing        :
thanks to CCBI...if a interpreter dosen't     1
create them it's non-conforming and thus      1
the validity of this program is NOT affected  p-
                                              >^
--written by Gamemanj,for Rosettacode


function rewritequotedparen(s)
    segments = split(s, "\"")
    for i in 1:length(segments)
        if i & 1 == 0  # even i
            ret = replace(segments[i], r"\(", s"_O_PAREN")
            segments[i] = replace(ret, r"\)", s"_C_PAREN")
        end
    end
    join(segments, "\"")
end

function reconsdata(n, s)
    if n > 1
        print(" ")
    end
    if s isa String && ismatch(r"[\$\%\!\$\#]", s) == false
        print("\"$s\"")
    else
        print(s)
    end
end

function printAny(anyarr)
    print("(")
    for (i, el) in enumerate(anyarr)
        if el isa Array
            print("(")
            for (j, el2) in enumerate(el)
                if el2 isa Array
                    print("(")
                    for(k, el3) in enumerate(el2)
                        if el3 isa Array
                            print(" (")
                            for(n, el4) in enumerate(el3)
                                reconsdata(n, el4)
                            end
                            print(")")
                        else
                            reconsdata(k, el3)
                        end
                    end
                    print(")")
                else
                    reconsdata(j, el2)
                end
            end
            if i == 1
                print(")\n ")
            else
                print(")")
            end
        end
    end
    println(")")
end

removewhitespace(s) = replace(replace(s, r"\n", " "), r"^\s*(\S.*\S)\s*$", s"\1")
quote3op(s) = replace(s, r"([\$\!\@\#\%]{3})", s"\"\1\"")
paren2bracket(s) = replace(replace(s, r"\(", s"["), r"\)", s"]")
data2symbol(s) = replace(s, "[data", "[:data")
unrewriteparens(s) = replace(replace(s, "_C_PAREN", ")"), "_O_PAREN", "(")
addcommas(s) = replace(replace(s, r"\]\s*\[", "],["), r" (?![a-z])", ",")

inputstring = """
((data "quoted data" 123 4.5)
 (data ([email protected]# (4.5) "(more" "data)")))
 """

println("The input string is:\n", inputstring)
processed = (inputstring |> removewhitespace |> rewritequotedparen |> quote3op
                        |> paren2bracket |> data2symbol |> unrewriteparens |> addcommas)
nat = eval(parse("""$processed"""))
println("The processed native structure is:\n", nat)
println("The reconstructed string is:\n"), printAny(nat)


// version 1.2.31

const val INDENT = 2

fun String.parseSExpr(): List<String>? {
    val r = Regex("""\s*("[^"]*"|\(|\)|"|[^\s()"]+)""")
    val t = r.findAll(this).map { it.value }.toMutableList()
    if (t.size == 0) return null
    var o = false
    var c = 0
    for (i in t.size - 1 downTo 0) {
        val ti = t[i].trim()
        val nd = ti.toDoubleOrNull()
        if (ti == "\"") return null
        if (ti == "(") {
            t[i] = "["
            c++
        }
        else if (ti == ")") {
            t[i] = "]"
            c--
        }
        else if (nd != null) {
             val ni = ti.toIntOrNull()
             if (ni != null) t[i] = ni.toString()
             else t[i] = nd.toString()
        }
        else if (ti.startsWith("\"")) { // escape embedded double quotes
             var temp = ti.drop(1).dropLast(1)
             t[i] = "\"" + temp.replace("\"", "\\\"") + "\""
        }
        if (i > 0 && t[i] != "]" && t[i - 1].trim() != "(") t.add(i, ", ")
        if (c == 0) {
            if (!o) o = true else return null
        }
    }
    return if (c != 0) null else t
}

fun MutableList<String>.toSExpr(): String {
    for (i in 0 until this.size) {
        this[i] = when (this[i]) {
            "["  -> "("
            "]"  -> ")"
            ", " -> " "
            else ->  {
                if (this[i].startsWith("\"")) { // unescape embedded quotes
                    var temp = this[i].drop(1).dropLast(1)
                    "\"" + temp.replace("\\\"", "\"") + "\""
                }
                else this[i]
            }
        }
    }
    return this.joinToString("")
}

fun List<String>.prettyPrint() {
    var level = 0
    [email protected]for (t in this) {
        var n: Int
        when(t) {
            ", ", " " -> continue@loop
            "[", "(" -> {
                n = level * INDENT + 1
                level++
             }
             "]", ")" -> {
                level--
                n = level * INDENT + 1
             }
             else -> {
                n = level * INDENT + t.length
             }
        }
        println("%${n}s".format(t))
    }
}

fun main(args: Array<String>) {
    val str = """((data "quoted data" 123 4.5)""" + "\n" +
              """ (data ([email protected]# (4.5) "(more" "data)")))"""
    val tokens = str.parseSExpr()
    if (tokens == null)
        println("Invalid s-expr!")
    else {
        println("Native data structure:")
        println(tokens.joinToString(""))
        println("\nNative data structure (pretty print):")
        tokens.prettyPrint()

        val tokens2 = tokens.toMutableList()
        println("\nRecovered S-Expression:")
        println(tokens2.toSExpr())
        println("\nRecovered S-Expression (pretty print):")
        tokens2.prettyPrint()
    }
}


func getThree(n) {
    var g3 = []
    for i in 0..33 {
        g3.Add(rnd(max: n) + 1)
    }
    g3.Sort()
    g3.RemoveAt(0)
    g3
}

func getSix() {
    var g6 = []
    for i in 0..5 {
        g6.Add(getThree(6).Sum())
    }
    g6
}

func Array.Sum() {
    var acc = 0
    for x in this {
        acc += x
    }
    acc
}

func Array.FindAll(pred) {
    for x in this when pred(x) {
        yield x
    }
}

var good = false

while !good {
    var gs = getSix()
    var gss = gs.Sum()
    var hvc = gs.FindAll(x => x > 14).Length()
    print("attribs: \(gs), sum=\(gss), ", terminator: "")
    let gl = gss >= 75 ? "good" : "low"
    print("(\(gl) sum, high vals=\(hvc))", terminator: "")
    good = gs.Sum() >= 75 && hvc > 1
    print(" - " + (good ? "success" : "failure"))
}


len v[] 6
repeat
  vsum = 0
  vmin = 0
  for i range 6
    val = 0
    min = 6
    for j range 4
      h = random 6 + 1
      val += h
      if h < min
        min = h
      .
    .
    val -= min
    v[i] = val
    if val >= 15
      vmin += 1
    .
    vsum += val
  .
  until vsum >= 75 and vmin >= 2
.
print "Attributes: " & " " & v[]
print "Total: " & " " & vsum


USING: combinators.short-circuit dice formatting io kernel math
math.statistics qw sequences ;
IN: rosetta-code.rpg-attributes-generator

CONSTANT: stat-names qw{ Str Dex Con Int Wis Cha }

: attribute ( -- n )
    4 [ ROLL: 1d6 ] replicate 3 <iota> kth-largests sum ;

: stats ( -- seq ) 6 [ attribute ] replicate ;

: valid-stats? ( seq -- ? )
    { [ [ 15 >= ] count 2 >= ] [ sum 75 >= ] } 1&& ;

: generate-valid-stats ( -- seq )
    stats [ dup valid-stats? ] [ drop stats ] until ;

: stats-info ( seq -- )
    [ sum ] [ [ 15 >= ] count ] bi
    "Total: %d\n# of attributes >= 15: %d\n" printf ;

: main ( -- )
    generate-valid-stats dup stat-names swap
    [ "%s: %d\n" printf ] 2each nl stats-info ;

MAIN: main


  ( run-length
  = character otherCharacter acc begin end
    .   :?acc
      & 0:?begin
      & @( !arg
         :   ?
             [!begin
             %@?character
             ?
             [?end
             (   (%@:~!character:?otherCharacter) ?
               & !acc !end+-1*!begin !character:?acc
               & !otherCharacter:?character
               & !end:?begin
               & ~`
             | &!acc !end+-1*!begin !character:?acc
             )
         )
      & str$!acc
  )
&   run-length$WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW


lpeg = require 'lpeg' -- see http://www.inf.puc-rio.br/~roberto/lpeg/

imports = 'P R S C V match'
for w in imports:gmatch('%a+') do _G[w] = lpeg[w] end -- make e.g. 'lpeg.P' function available as 'P'

function tosymbol(s) return s end
function tolist(x, ...) return {...} end -- ignore the first capture, the whole sexpr

ws = S' \t\n'^0                 -- whitespace, 0 or more

digits = R'09'^1                -- digits, 1 or more
Tnumber = C(digits * (P'.' * digits)^-1) * ws / tonumber -- ^-1 => at most 1

Tstring = C(P'"' * (P(1) - P'"')^0 * P'"') * ws

sep = S'()" \t\n'
symstart = (P(1) - (R'09' + sep))
symchar = (P(1) - sep)
Tsymbol = C(symstart * symchar^0) * ws / tosymbol

atom = Tnumber + Tstring + Tsymbol
lpar = P'(' * ws
rpar = P')' * ws
sexpr = P{ -- defines a recursive pattern
    'S';
    S = ws * lpar * C((atom + V'S')^0) * rpar / tolist
}


#define min(a, b) iif(a < b, a, b)

function d6() as integer
    'simulates a marked regular hexahedron coming to rest on a plane
    return 1+int(rnd*6)
end function

function roll_stat() as integer
    'rolls four dice, returns the sum of the three highest
    dim as integer a=d6(), b=d6(), c=d6(), d=d6()
    return a + b + c + d - min( min(a, b), min(c, d) )
end function

dim as string*3 statnames(1 to 6) = {"STR", "CON", "DEX", "INT", "WIS", "CHA"}
dim as integer stat(1 to 6), n15, sum
dim as boolean acceptable = false

randomize timer
do
    sum = 0
    n15 = 0
    for i as integer = 1 to 6
        stat(i) = roll_stat()
        sum = sum + stat(i)
        if stat(i)>=15 then n15 += 1
    next i
    if sum>=75 and n15 >=2 then acceptable = true
loop until acceptable

for i as integer = 1 to 6
    print using "&:  ##";statnames(i);stat(i)
next i
print "--------"
print using "TOT:  ##";sum


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

typedef struct stream_t stream_t, *stream;
struct stream_t {
	/* get function is supposed to return a byte value (0-255),
		or -1 to signify end of input */
	int (*get)(stream);
	/* put function does output, one byte at a time */
	int (*put)(stream, int);
};

/* next two structs inherit from stream_t */
typedef struct {
	int (*get)(stream);
	int (*put)(stream, int);
	char *string;
	int pos;
} string_stream;

typedef struct {
	int (*get)(stream);
	int (*put)(stream, int);
	FILE *fp;
} file_stream;

/* methods for above streams */
int sget(stream in)
{
	int c;
	string_stream* s = (string_stream*) in;
	c = (unsigned char)(s->string[s->pos]);
	if (c == '\0') return -1;
	s->pos++;
	return c;
}

int sput(stream out, int c)
{
	string_stream* s = (string_stream*) out;
	s->string[s->pos++] = (c == -1) ? '\0' : c;
	if (c == -1) s->pos = 0;
	return 0;
}

int file_put(stream out, int c)
{
	file_stream *f = (file_stream*) out;
	return fputc(c, f->fp);
}

/* helper function */
void output(stream out, unsigned char* buf, int len)
{
	int i;
	out->put(out, 128 + len);
	for (i = 0; i < len; i++)
		out->put(out, buf[i]);
}

/* Specification: encoded stream are unsigned bytes consisting of sequences.
 * First byte of each sequence is the length, followed by a number of bytes.
 * If length <=128, the next byte is to be repeated length times;
 * If length > 128, the next (length - 128) bytes are not repeated.
 * this is to improve efficiency for long non-repeating sequences.
 * This scheme can encode arbitrary byte values efficiently.
 * c.f. Adobe PDF spec RLE stream encoding (not exactly the same)
 */
void encode(stream in, stream out)
{
	unsigned char buf[256];
	int len = 0, repeat = 0, end = 0, c;
	int (*get)(stream) = in->get;
	int (*put)(stream, int) = out->put;

	while (!end) {
		end = ((c = get(in)) == -1);
		if (!end) {
			buf[len++] = c;
			if (len <= 1) continue;
		}

		if (repeat) {
			if (buf[len - 1] != buf[len - 2])
				repeat = 0;
			if (!repeat || len == 129 || end) {
				/* write out repeating bytes */
				put(out, end ? len : len - 1);
				put(out, buf[0]);
				buf[0] = buf[len - 1];
				len = 1;
			}
		} else {
			if (buf[len - 1] == buf[len - 2]) {
				repeat = 1;
				if (len > 2) {
					output(out, buf, len - 2);
					buf[0] = buf[1] = buf[len - 1];
					len = 2;
				}
				continue;
			}
			if (len == 128 || end) {
				output(out, buf, len);
				len = 0;
				repeat = 0;
			}
		}
	}
	put(out, -1);
}

void decode(stream in, stream out)
{
	int c, i, cnt;
	while (1) {
		c = in->get(in);
		if (c == -1) return;
		if (c > 128) {
			cnt = c - 128;
			for (i = 0; i < cnt; i++)
				out->put(out, in->get(in));
		} else {
			cnt = c;
			c = in->get(in);
			for (i = 0; i < cnt; i++)
				out->put(out, c);
		}
	}
}

int main()
{
	char buf[256];
	string_stream str_in = { sget, 0,
		"WWWWWWWWWWWWBWWWWWWWWWWWWBBBWWWWWWWWWWWWWWWWWWWWWWWWBWWWWWWWWWWWWWW", 0};
	string_stream str_out = { sget, sput, buf, 0 };
	file_stream file = { 0, file_put, stdout };

	/* encode from str_in to str_out */
	encode((stream)&str_in, (stream)&str_out);

	/* decode from str_out to file (stdout) */
	decode((stream)&str_out, (stream)&file);

	return 0;
}


import strutils

const Input = """
((data "quoted data" 123 4.5)
 (data ([email protected]# (4.5) "(more" "data)")))
"""

type
  TokenKind = enum
    tokInt, tokFloat, tokString, tokIdent
    tokLPar, tokRPar
    tokEnd
  Token = object
    case kind: TokenKind
    of tokString: stringVal: string
    of tokInt: intVal: int
    of tokFloat: floatVal: float
    of tokIdent: ident: string
    else: discard

proc lex(input: string): seq[Token] =
  var pos = 0

  template current: char =
    if pos < input.len: input[pos]
    else: '\x00'

  while pos < input.len:
    case current
    of ';':
      inc(pos)
      while current notin {'\r', '\n'}:
        inc(pos)
      if current == '\r': inc(pos)
      if current == '\n': inc(pos)
    of '(': inc(pos); result.add(Token(kind: tokLPar))
    of ')': inc(pos); result.add(Token(kind: tokRPar))
    of '0'..'9':
      var
        num = ""
        isFloat = false
      while current in Digits:
        num.add(current)
        inc(pos)
      if current == '.':
        num.add(current)
        isFloat = true
        inc(pos)
        while current in Digits:
          num.add(current)
          inc(pos)
      result.add(if isFloat: Token(kind: tokFloat, floatVal: parseFloat(num))
                 else: Token(kind: tokInt, intVal: parseInt(num)))
    of ' ', '\t', '\n', '\r': inc(pos)
    of '"':
      var str = ""
      inc(pos)
      while current != '"':
        str.add(current)
        inc(pos)
      inc(pos)
      result.add(Token(kind: tokString, stringVal: str))
    else:
      const BannedChars = {' ', '\t', '"', '(', ')', ';'}
      var ident = ""
      while current notin BannedChars:
        ident.add(current)
        inc(pos)
      result.add(Token(kind: tokIdent, ident: ident))
  result.add(Token(kind: tokEnd))

type
  SExprKind = enum
    seInt, seFloat, seString, seIdent, seList
  SExpr = ref object
    case kind: SExprKind
    of seInt: intVal: int
    of seFloat: floatVal: float
    of seString: stringVal: string
    of seIdent: ident: string
    of seList: children: seq[SExpr]
  ParseError = object of CatchableError

proc `$`*(se: SExpr): string =
  case se.kind
  of seInt: result = $se.intVal
  of seFloat: result = $se.floatVal
  of seString: result = '"' & se.stringVal & '"'
  of seIdent: result = se.ident
  of seList:
    result = "("
    for i, ex in se.children:
      if ex.kind == seList and ex.children.len > 1:
        result.add("\n")
        result.add(indent($ex, 2))
      else:
        if i > 0:
          result.add(" ")
        result.add($ex)
    result.add(")")

var
  tokens = lex(Input)
  pos = 0

template current: Token =
  if pos < tokens.len: tokens[pos]
  else: Token(kind: tokEnd)

proc parseInt(token: Token): SExpr =
  result = SExpr(kind: seInt, intVal: token.intVal)

proc parseFloat(token: Token): SExpr =
  result = SExpr(kind: seFloat, floatVal: token.floatVal)

proc parseString(token: Token): SExpr =
  result = SExpr(kind: seString, stringVal: token.stringVal)

proc parseIdent(token: Token): SExpr =
  result = SExpr(kind: seIdent, ident: token.ident)

proc parse(): SExpr

proc parseList(): SExpr =
  result = SExpr(kind: seList)
  while current.kind notin {tokRPar, tokEnd}:
    result.children.add(parse())
  if current.kind == tokEnd:
    raise newException(ParseError, "Missing right paren ')'")
  else:
    inc(pos)

proc parse(): SExpr =
  var token = current
  inc(pos)
  result =
    case token.kind
    of tokInt: parseInt(token)
    of tokFloat: parseFloat(token)
    of tokString: parseString(token)
    of tokIdent: parseIdent(token)
    of tokLPar: parseList()
    else: nil

echo parse()