#!/usr/bin/env node
import { writeFileSync, existsSync, readFileSync, unlinkSync } from 'node:fs';
//https://www.elitizon.com/2021/01-09-how-to-create-a-cli-command-with-typescript/#:~:text=%20Boost%20your%20productivity%20by%20creating%20your%20own,information.%20Required%3A%20string.%20%20...%20%20More%20

const a:string[] = process.argv;
const argv:string[] = a.splice(2)
/**
 *  Extension of the pad files
 */
const padExtension:string = ".1tp";
/**
 * Extension of the key generated
 */
const keyExtension:string = ".key";
/**
 * Array of commands usable
 */
const commands:string[] = ["--generate", "--encrypt","--decrypt"];
/**
 * The alphabet
 */
const stringLetter = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

/**
 * Main function
 */
const main = ():void => {
    // if no args have been give display help
    if(argv.length == 0){
        help();
        return;
    }

    // Check if there is a command in the file
    if(commands.includes(argv[0])){
        let choise = argv[0].trim().toLowerCase();
        if(choise === "--generate"){
                console.log("Generating action chosen");

                // Check if the arguments have been given to generate a new key
                if(!argv[1]){
                    ("Pad name not specified")
                    help();
                    return;
                }

                // Check if the length of the filename is at least 4 characters
                if(argv[1].length <= 3){
                    console.log("The name of the pad should be at least 4 letters long");
                    help();
                    return;
                }

                // Check if the filesize is a number(should be the second argv)
                let fileSize = +argv[2];
                if(isNaN(fileSize)){
                    console.log("File size should be a number");
                    help();
                    return
                }

                createFile(argv[1], fileSize)
        }

        // If the selected action is to encrypt
        if( choise === "--encrypt"){
                console.log("Encrypting action chosen");
                let padDataName = argv[2] ? `${argv[2].trim()}${padExtension}` : `${argv[1].trim()}${padExtension}`

                // Check if the files exist
                if(!argv[1] && !argv[2]){
                    console.log("Parameters not given");
                    help();
                    return;
                }

                // Check if the text file exists and the pad file
                if(!existsSync(`${argv[1].trim().toLowerCase()}.txt`)){
                    console.log("Text file doesn't exit");
                    help();
                    return;
                }

                console.log("Reading file")
                // Get the data from the file as well as the data from the padfile
                let fileDataEnc = readFileSync(`${argv[1].trim().toLowerCase()}.txt`, 'utf-8');

                if(!existsSync(`${argv[2]}${padExtension}`)){
                    console.log("1tp file doesn't exist, generating new 1pt file");
                    createFile(argv[1], fileDataEnc.length);
                }

                console.log("Reading 1pt file");
                // Get the pad data
                let padDataEnc = RetrievePadData(padDataName);

                // if the file 1pt file has been specified but it's not big enough
                if(fileDataEnc.length > padDataEnc.length){
                    console.log("The file is bigger than the 1tp file. Generating a new padfile");
                    createFile(argv[1], fileDataEnc.length);
                    padDataEnc = RetrievePadData(`${argv[1]}${padExtension}`)
                }

                console.log("Converting the file");
                let keyEnc = padFunction(fileDataEnc,padDataEnc);
                createFile(`${argv[1]}.key`, keyEnc.length, false, keyEnc);

        }

        if(choise === "--decrypt"){
                console.log("Decrypting action chosen");

                // Check if the necessary args were given
                if(!argv[1]){
                    console.log("No file specified For decryption specified")
                    return;
                }
                if(!argv[2]){
                    console.log("No 1pt file was given, Please specify the file to use");
                    return;
                }
                if(!argv[3] || argv[3].trim() != '-o') {
                   console.log("No file for output specified");
                }

                let fileNameDec = `${argv[1].trim()}${keyExtension}`;
                let padNameDec = `${argv[2].trim()}${padExtension}`;

                // Check if the files exists or not
                if(!existsSync(fileNameDec)){
                    console.log("File specified does not exist");
                    return;
                }
                if(!existsSync(padNameDec)){
                    console.log("1pt file specified doesn't exist");
                    return;
                }

                console.log("Read the encrypted file");
                let fileDataDec = readFileSync(fileNameDec, 'utf-8');
                console.log("Reading the 1pt file");
                let padDataDec = RetrievePadData(padNameDec);

                // decrypt the file
                console.log("Generating the file");
                let keyDec = padFunction(fileDataDec, padDataDec)

                if(argv[3] && argv[3].trim()==='-o'){
                    let textFileDec = `${argv[1].trim()}.txt`;
                    if(!argv[4]){
                        console.log("No output file specified, creating a new file")
                    }
                    if(argv[4] && argv[4].trim().length < 3){
                        console.log("The name of the output file should be greater than 4 characters");
                        console.log(`Creating new file`)
                    }else {
                        argv[4] ? textFileDec = `${argv[4].trim()}.txt` : textFileDec = `${argv[1].trim()}.txt`
                    }

                    console.log("Generating text file");
                    createFile(textFileDec, 0, false, keyDec );
                    // https://sebhastian.com/javascript-delete-file/
                    console.log("Deleting encrypted file");
                    unlinkSync(fileNameDec);
                    console.log("Deleting 1pt file");
                    unlinkSync(padNameDec);
                }else {
                    console.log("The decrypted file is: \n\n")
                    console.log(keyDec);
                }
        }

    }else {
        console.log("Invalid action");
        help();
        return;
    }

}

/**
 * Display help messages
 */
const help = ():void => {
    console.log("\n\n\n1tp is a tool used to encrypt and decrypt text files");
    console.log("Look at the commands below to learn the use of it");
    console.log("The input file for encryption should be a txt file");
    console.log("The output will be a .kye file and a .1pt file");
    console.log("\n\n**Note: Don't add file extensios while running the command**");
    console.log("**Note: if during creation, the application encouters a file already existing, it will overwrite the file**");
    console.log("Options: ");
    console.log("\t -h | --help \t\t\t\t\t\t\t View help");
    console.log("\t --generate <pad name> <size of file> \t\t\t\t Create a pad file given a size");
    console.log("\t --encrypt <txt file> <pad name> \t\t\t\t Encrypt a file give a pad file");
    console.log("\t\t\t\t All parameters for encryption are required");
    console.log("\t --decrypt <key file> <pad name> -o <txt file>  \t Decrypt a file give a key and 1tp files");
    console.log("\t\t\t\t If output file is not specified it will display the text inside the console");
    console.log("\t\t\t\t If only the `-o` option is defined without a txt file, it will create a new file");
    console.log("\n** Note: Decrypting a file will delete the key and the 1pt files**");
}

/**
 * Create a file with a random key
 * @param file Name of the file being created
 * @param fileSize Size of the file being created
 */
const createFile = (file:string, fileSize:number = 1024, key:boolean = true, data:string = ""):void => {
    let fileName:string;
    if(key){
        fileName = `${file.trim().toLowerCase()}${padExtension}`;

        // https://flaviocopes.com/how-to-check-if-file-exists-node/#:~:text=The%20way%20to%20check%20if%20a%20file%20exists,the%20existence%20of%20a%20file%20without%20opening%20it%3A

        console.log("Generating the One time pad");
        const pad = generateOneTimePad(fileSize);
        //https://code-boxx.com/create-save-files-javascript/#:~:text=%20The%20possible%20ways%20to%20create%20and%20save,the%20server.%0Avar%20data%20%3D%20new%20FormData...%20More%20
        console.log("Writing to file");
        writeFileSync(fileName, pad);
        return;

    }

    console.log("Writing to file");
    writeFileSync(file, data);
};

/**
 * Generate a pad
 * @param fileSize Size of the new pad being created
 * @returns the new pad
 */
const generateOneTimePad = (fileSize:number):string => {
    /**
     * String in which we will put the one time pad
     */
    let otp:string = "";
    /**
     * used to organize the key
     */
    let splitCounter = 0;
    let columnCounter = 0;

    for (let i = 0; i <= fileSize;) {
        if(splitCounter < 6){
            // Generate a random letter from the alphabet given
            otp += (stringLetter.charAt(Math.random()*1000%stringLetter.length))
            splitCounter++;
            i++;
            continue;
        }
        // Used to organize the key so it looks estetic
        if(columnCounter < 7){
            splitCounter = 0;
            columnCounter++;
            otp += ("\t");
            continue;
        }else{
            splitCounter = 0;
            columnCounter = 0;
            otp += ("\n");
            continue;
        }

    }
    return otp
}

/**
 * Get the pad data from the file
 * @returns Text pad data
 */
const RetrievePadData = (padFile:string):string => {
    // Retrieve the pad data
    let padData = ""
    // read the file
    const data = readFileSync(`${padFile}`, 'utf-8')

    // Take out all the tabs and new lines we added while generating the key
    const stringArray = data.toString().split("\n");
    for (let index = 0; index < stringArray.length; index++) {
        const element = stringArray[index].split("\t");
        for (let i = 0; i < element.length; i++) {
            padData += element[i];
        }
    }

    return padData;
}

/**
 * One time pad function
 * @param fileData Data of the file to encrypt or decrypt
 * @param padData Data of the pad file
 * @returns The generated encryption or decryption
 */
const padFunction = (fileData:string, padData:string ):string => {
    let key = "";
    for (let i = 0; i < fileData.length; i++) {
        key += String.fromCharCode(-fileData[i].charCodeAt(0)+padData[i].toLowerCase().charCodeAt(0)+97);
        // console.log(`File char: ${fileData[i]} ${fileData[i].charCodeAt(0)}   Pad Data: ${padData[i]} ${padData[i].toLocaleLowerCase().charCodeAt(0)}   Key: ${key[i]} ${key[i].charCodeAt(0)}`)
    }
    return key;
}

main();


with Ada.Text_IO;

procedure Odd_Word_Problem is

   use Ada.Text_IO; -- Get, Put, and Look_Ahead

   function Current return Character is
      -- reads the current input character, without consuming it
      End_Of_Line: Boolean;
      C: Character;
   begin
      Look_Ahead(C, End_Of_Line);
      if End_Of_Line then
         raise Constraint_Error with "end of line before the terminating '.'";
      end if;
      return C;
   end Current;

   procedure Skip is
      -- consumes the current input character
      C: Character;
   begin
      Get(C);
   end Skip;

   function Is_Alpha(Ch: Character) return Boolean is
   begin
      return (Ch in  'a' .. 'z') or (Ch in 'A' .. 'Z');
   end Is_Alpha;

   procedure Odd_Word(C: Character) is
   begin
      if Is_Alpha(C) then
         Skip;
         Odd_Word(Current);
         Put(C);
      end if;
   end Odd_Word;

begin -- Odd_Word_Problem
   Put(Current);
   while Is_Alpha(Current) loop -- read an even word
      Skip;
      Put(Current);
   end loop;
   if Current /= '.' then -- read an odd word
      Skip;
      Odd_Word(Current);
      Put(Current);
      if Current /= '.' then -- read the remaining words
         Skip;
         Odd_Word_Problem;
      end if;
   end if;
end Odd_Word_Problem;


# recursively reverses the current word in the input and returns the    #
# the character that followed it                                        #
# "ch" should contain the first letter of the word on entry and will be #
# updated to the punctuation following the word on exit                 #
PROC reverse word = ( REF CHAR ch )VOID:
BEGIN

    CHAR    next ch;

    read( ( next ch ) );

    IF ( next ch <= "Z" AND next ch >= "A" )
    OR ( next ch <= "z" AND next ch >= "a" )
    THEN
        reverse word( next ch )
    FI;

    print( ( ch ) );

    ch := next ch

END; # reverse word #

# recursively prints the current word in the input and returns the      #
# character that followed it                                            #
# "ch" should contain the first letter of the word on entry and will be #
# updated to the punctuation following the word on exit                 #
PROC normal word = ( REF CHAR ch )VOID:
BEGIN

    print( ( ch ) );
    read ( ( ch ) );

    IF ( ch <= "Z" AND ch >= "A" )
    OR ( ch <= "z" AND ch >= "a" )
    THEN
        normal word( ch )
    FI

END; # normal word #

# read and print words and punctuation from the input stream, reversing #
# every second word                                                     #
PROC reverse every other word = VOID:
BEGIN

    CHAR ch;

    read( ( ch ) );

    WHILE
        ch /= "."
    DO
        normal word( ch );
        IF ch /= "."
        THEN
            print( ( ch ) );
            read ( ( ch ) );
            reverse word( ch )
        FI
    OD;

    print( ( ch ) )

END; # reverse every other word #

main: (
    reverse every other word
)


str := "what,is,the;meaning,of:life."
loop, parse, str
	if (A_LoopField ~= "[[:punct:]]")
		res .= A_LoopField, toggle:=!toggle
	else
		res := toggle ? RegExReplace(res, ".*[[:punct:]]\K", A_LoopField ) : res A_LoopField
MsgBox % res


OPEN "/dev/stdin" FOR DEVICE AS in

FUNCTION get_odd()

    LOCAL ch, letter

    ch = MEMORY(1)
    GETBYTE ch FROM in

    IF NOT(REGEX(CHR$(PEEK(ch)), "[[:punct:]]")) THEN
        letter = get_odd()
        PRINT CHR$(PEEK(ch));
    ELSE
        letter = PEEK(ch)
    END IF

    FREE ch
    RETURN letter

END FUNCTION

mem = MEMORY(1)
PRINT "Enter string: ";

WHILE TRUE

    GETBYTE mem FROM in
    PRINT CHR$(PEEK(mem));

    IF REGEX(CHR$(PEEK(mem)), "[[:punct:]]") THEN
        IF PEEK(mem) <> 46 THEN
            POKE mem, get_odd()
            PRINT CHR$(PEEK(mem));
        END IF
        IF PEEK(mem) = 46 THEN BREAK
    END IF
WEND

FREE mem
CLOSE DEVICE in

PRINT


( ( odd-word
  =   dothis doother forward backward
    .   ( forward
        =   ch
          .   fil$:?ch
            & put$!ch
            & ( low$!ch:~<a:~>z&forward$
              | !ch:~"."
              )
        )
      & ( backward
        =   ch
          .   fil$:?ch
            & (   low$!ch:~<a:~>z
                & backward$() (put$!ch&)    { This reduces to the return value of backwards$()}
              | '(.put$($ch)&$ch:~".")      { Macro, evaluates to a function with actual ch.  }
              )
        )
      & fil$(!arg,r)
      &   ((=forward$).(=(backward$)$))
        : (?dothis.?doother)
      &   whl
        ' ( !(dothis.)
          & (!doother.!dothis):(?dothis.?doother)
          )
      & (fil$(,SET,-1)|)                 { This is how a file is closed: seek the impossible. }
  )
& put$("what,is,the;meaning,of:life.","life.txt",NEW)
& put$("we,are;not,in,kansas;any,more.","kansas.txt",NEW)
& odd-word$"life.txt"
& put$\n
& odd-word$"kansas.txt"    { Real file, as Bracmat cannot read a single character from stdin. }
);


#include <stdio.h>
#include <ctype.h>

static int
owp(int odd)
{
        int ch, ret;
        ch = getc(stdin);
        if (!odd) {
                putc(ch, stdout);
                if (ch == EOF || ch == '.')
                        return EOF;
                if (ispunct(ch))
                        return 0;
                owp(odd);
                return 0;
        } else {
                if (ispunct(ch))
                        return ch;
                ret = owp(odd);
                putc(ch, stdout);
                return ret;
        }
}

int
main(int argc, char **argv)
{
        int ch = 1;
        while ((ch = owp(!ch)) != EOF) {
                if (ch)
                        putc(ch, stdout);
                if (ch == '.')
                        break;
        }
        return 0;
}


#include <iostream>
#include <cctype>
#include <functional>

using namespace std;

bool odd()
{
  function<void ()> prev = []{};
  while(true) {
    int c = cin.get();
    if (!isalpha(c)) {
      prev();
      cout.put(c);
      return c != '.';
    }
    prev = [=] { cout.put(c); prev();  };
  }
}

bool even()
{
  while(true) {
    int c;
    cout.put(c = cin.get());
    if (!isalpha(c)) return c != '.';
  }
}

int main()
{
  bool e = false;
  while( e ? odd() : even() ) e = !e;
  return 0;
}


String[] meaning = ["what,", "is,", "the;", "meaning,", "of:", "life."];
String[] kansas = ["we,", "are,", "not,", "in,", "kansas;", "any,", "more."];

shared void run() {
    print("".join(reverseWords(meaning)));
    print("".join(reverseWords(kansas)));
}

String[] reverseWords(String[] words)
    => recursiveReverseWords(words, []);

String[] recursiveReverseWords(String[] remOrig, String[] revWords)
    => if (nonempty remOrig)
        then recursiveReverseWords(remOrig.rest,
                                   revWords.withTrailing(reverseWordRecursive(remOrig.first.sequence(),
                                                                              [],
                                                                              revWords.size.even)))
        else revWords;

String reverseWordRecursive(Character[] remOldChars, Character[] revChars, Boolean isEven)
    => if (nonempty remOldChars)
        then let (char = remOldChars.first) reverseWordRecursive(remOldChars.rest,
                                                                 conditionalAddChar(char, revChars, isEven),
                                                                 isEven)
        else String(revChars);

Character[] conditionalAddChar(Character char, Character[] chars, Boolean isEven)
    => if (isEven || isPunctuation(char))
        then chars.withTrailing(char)
        else chars.withLeading(char);

Boolean isPunctuation(Character char)
    => ",.:;".contains(char);


(defn next-char []
  (char (.read *in*)))

(defn forward []
  (let [ch (next-char)]
    (print ch)
    (if (Character/isLetter ch)
      (forward)
      (not= ch \.))))

(defn backward []
  (let [ch (next-char)]
    (if (Character/isLetter ch)
      (let [result (backward)]
        (print ch)
        result)
      (fn [] (print ch) (not= ch \.)))) )

(defn odd-word [s]
  (with-in-str s
    (loop [forward? true]
      (when (if forward?
              (forward)
              ((backward)))
        (recur (not forward?)))) )
    (println))


isWordChar = (c) -> /^\w/.test c
isLastChar = (c) -> c is '.'

# Pass a function that returns an input character and one that outputs a
# character. JS platforms' ideas of single-character I/O vary widely, but this
# abstraction is adaptable to most or all.
oddWord = (get, put) ->
	forwardWord = ->
		loop
			# No magic here; buffer then immediately output.
			c = get()
			put(c)
			unless isWordChar(c)
				return not isLastChar(c)

	# NB: (->) is a CoffeeScript idiom for no-op.
	reverseWord = (outputPending = (->)) ->
		c = get()
		if isWordChar(c)
			# Continue word.
			# Tell recursive call to output this character, then any previously
			# pending characters, after the next word character, if any, has
			# been output.
			reverseWord ->
				put(c)
				outputPending()
		else
			# Word is done.
			# Output previously pending characters, then this punctuation.
			outputPending()
			put(c)
			return not isLastChar(c)

	# Alternate between forward and reverse until one or the other reports that
	# the end-of-input mark has been reached (causing a return of false).
	continue while forwardWord() and reverseWord()


(defun odd-word (s)
  (let ((stream (make-string-input-stream s)))
    (loop for forwardp = t then (not forwardp)
          while (if forwardp
                    (forward stream)
                    (funcall (backward stream)))) ))

(defun forward (stream)
  (let ((ch (read-char stream)))
    (write-char ch)
    (if (alpha-char-p ch)
	(forward stream)
        (char/= ch #\.))))

(defun backward (stream)
  (let ((ch (read-char stream)))
    (if (alpha-char-p ch)
        (prog1 (backward stream) (write-char ch))
        #'(lambda () (write-char ch) (char/= ch #\.)))) )


bool doChar(in bool odd, in void delegate() nothrow f=null) nothrow {
    import core.stdc.stdio, std.ascii;

    immutable int c = getchar;
    if (!odd)
        c.putchar;
    if (c.isAlpha)
        return doChar(odd, { c.putchar; if (f) f(); });
    if (odd) {
        if (f) f();
        c.putchar;
    }
    return c != '.';
}

void main() {
    bool i = true;
    while (doChar(i = !i)) {}
}


program Odd_word_problem;

{$APPTYPE CONSOLE}

uses
  System.SysUtils,
  System.Console,
  System.Character;

function doChar(isOdd: boolean; f: TProc = nil): Boolean;
begin
  var c: char := Console.ReadKey(True).KeyChar;

  if not isOdd then
    Write(c);

  if c.IsLetter then
    exit(doChar(isOdd,
      procedure
      begin
        Write(c);
        if assigned(f) then
          f();
      end));

  if isOdd then
  begin
    if Assigned(f) then
      f();
    write(c);
  end;

  exit(c <> '.');

end;

begin
  var i: boolean := false;
  while doChar(i) do
    i := not i;
  readln;
end.


(lib 'sequences)
(define input-stream null)
(define output-stream "")

;;---------------------------
;; character I/O simulation
;; --------------------------
(define (read-char) (next input-stream)) ;; #f if EOF
(define (write-char c) (when c (set! output-stream (string-append output-stream c))))

(define (init-streams sentence)
	(set! input-stream (procrastinator sentence))
	(set! output-stream ""))

;;---------------------------------
;; task , using read-char/write-char
;;----------------------------------

(define (flop) ; reverses,  and returns first non-alpha after word, or EOF
	(define c (read-char))
	(if (string-alphabetic? c) (begin0 (flop) (write-char c)) c))

(define (flip)
    (define c (read-char))
    (if (string-alphabetic? c) (begin (write-char c)  (flip)) c))

(define (task sentence)
	 (init-streams sentence)
	 (while (and (write-char (flip)) (write-char (flop))))
	 output-stream )


defmodule Odd_word do
  def handle(s, false, i, o) when ((s >= "a" and s <= "z") or (s >= "A" and s <= "Z")) do
    o.(s)
    handle(i.(), false, i, o)
  end
  def handle(s, t, i, o) when ((s >= "a" and s <= "z") or (s >= "A" and s <= "Z")) do
    d = handle(i.(), :rec, i, o)
    o.(s)
    if t == true, do: handle(d, t, i, o), else: d
  end
  def handle(s, :rec, _, _), do: s
  def handle(?., _, _, o), do: o.(?.); :done
  def handle(:eof, _, _, _), do: :done
  def handle(s, t, i, o) do
    o.(s)
    handle(i.(), not t, i, o)
  end

  def main do
    i = fn() -> IO.getn("") end
    o = fn(s) -> IO.write(s) end
    handle(i.(), false, i, o)
  end
end

Odd_word.main


handle(S, false, I, O) when (((S >= $a) and (S =< $z)) or ((S >= $A) and (S =< $Z))) ->
    O(S),
    handle(I(), false, I, O);
handle(S, T, I, O) when (((S >= $a) and (S =< $z)) or ((S >= $A) and (S =< $Z))) ->
    D = handle(I(), rec, I, O),
    O(S),
    case T of true -> handle(D, T, I, O); _ -> D end;
handle(S, rec, _, _) -> S;
handle($., _, _, O) -> O($.), done;
handle(eof, _, _, _) -> done;
handle(S, T, I, O) -> O(S), handle(I(), not T, I, O).

main([]) ->
    I = fun() -> hd(io:get_chars([], 1)) end,
    O = fun(S) -> io:put_chars([S]) end,
    handle(I(), false, I, O).


open System
open System.Text.RegularExpressions

let mutable Inp = Console.In

let Out c = printf "%c" c; (if c = '.' then Environment.Exit 0)

let In() = Inp.Read() |> Convert.ToChar

let (|WordCharacter|OtherCharacter|) c =
    if Regex.IsMatch(c.ToString(),"[a-zA-Z]") then
        WordCharacter
    else
        OtherCharacter

let rec forward () =
    let c = In()
    let rec backward () : char =
        let c = In()
        match c with
        | WordCharacter ->
            let s = backward() in Out c; s
        | OtherCharacter -> c
    Out c
    match c with
    | WordCharacter -> forward()
    | OtherCharacter -> backward()

[<EntryPoint>]
let main argv =
    if argv.Length > 0 then Inp <- new System.IO.StringReader(argv.[0])
    let rec loop () = forward() |> Out;  loop()
    loop()
    0


USING: continuations kernel io io.streams.string locals unicode.categories ;
IN: rosetta.odd-word

<PRIVATE
! Save current continuation.
: savecc ( -- continuation/f )
    [ ] callcc1 ; inline

! Jump back to continuation, where savecc will return f.
: jump-back ( continuation -- )
    f swap continue-with ; inline
PRIVATE>

:: read-odd-word ( -- )
    f :> first-continuation!
    f :> last-continuation!
    f :> reverse!
    ! Read characters. Loop until end of stream.
    [ read1 dup ] [
        dup Letter? [
            ! This character is a letter.
            reverse [
                ! Odd word: Write letters in reverse order.
                last-continuation savecc dup [
                    last-continuation!
                    2drop       ! Drop letter and previous continuation.
                ] [
                    ! After jump: print letters in reverse.
                    drop                ! Drop f.
                    swap write1         ! Write letter.
                    jump-back           ! Follow chain of continuations.
                ] if
            ] [
                ! Even word: Write letters immediately.
                write1
            ] if
        ] [
            ! This character is punctuation.
            reverse [
                ! End odd word. Fix trampoline, follow chain of continuations
                ! (to print letters in reverse), then bounce off trampoline.
                savecc dup [
                    first-continuation!
                    last-continuation jump-back
                ] [ drop ] if
                write1                  ! Write punctuation.
                f reverse!              ! Begin even word.
            ] [
                write1                  ! Write punctuation.
                t reverse!              ! Begin odd word.
                ! Create trampoline to bounce to (future) first-continuation.
                savecc dup [
                    last-continuation!
                ] [ drop first-continuation jump-back ] if
            ] if
        ] if
    ] while
    ! Drop f from read1. Then print a cosmetic newline.
    drop nl ;

: odd-word ( string -- )
    [ read-odd-word ] with-string-reader ;


: word?  dup [char] . <> over bl <> and ;
: ?quit  dup [char] . = if emit quit then ;
: eatbl  begin dup bl = while drop key repeat ?quit ;
: even   begin word? while emit key repeat ;
: odd    word? if key recurse swap emit then ;
: main   cr key eatbl begin even eatbl space odd eatbl space again ;


      MODULE ELUDOM	!Uses the call stack for auxiliary storage.
       INTEGER MSG,INF	!I/O unit numbers.
       LOGICAL DEFER	!To stumble, or not to stumble.
       CONTAINS
        CHARACTER*1 RECURSIVE FUNCTION GET(IN)	!Returns one character, going forwards.
         INTEGER IN	!The input file.
         CHARACTER*1 C	!The single character to be read therefrom.
          READ (IN,1,ADVANCE="NO",EOR=3,END=4) C	!Thus. Not advancing to the next record.
    1     FORMAT (A1,$)	!For output, no advance to the next line either.
    2     IF (("A"<=C .AND. C<="Z").OR.("a"<=C .AND. C<="z")) THEN	!Unsafe for EBCDIC.
            IF (DEFER) THEN	!Are we to reverse the current text?
              GET = GET(IN)	!Yes. Go for the next letter.
              WRITE (MSG,1) C	!And now, backing out, reveal the letter at this level.
              RETURN		!Retreat another level.
            END IF		!Thus passing back the ending non-letter that was encountered.
           ELSE		!And if we've encountered a non-letter,
            DEFER = .NOT. DEFER	!Then our backwardness flips.
          END IF	!Enough inspection of C.
    3     GET = C	!Pass it back.
          RETURN	!And we're done.
    4     GET = CHAR(0)	!Reserving this for end-of-file.
        END FUNCTION GET!That was strange.
      END MODULE ELUDOM	!But as per the specification.

      PROGRAM CONFUSED	!Just so.
      USE ELUDOM	!Forwards? Backwards?
      CHARACTER*1 C	!A scratchpad for multiple inspections.
      MSG = 6	!Standard output.
      INF = 10	!This will do.
      OPEN (INF,NAME = "Confused.txt",STATUS="OLD",ACTION="READ")	!Go for the file.

Chew through the input. A full stop marks the end.
   10 DEFER = .FALSE.	!Start off going forwards.
   11 C = GET(INF)		!Get some character from file INF.
      IF (ICHAR(C).LE.0) STOP		!Perhaps end-of-file is reported.
      IF (C.NE." ") WRITE (MSG,12) C	!Otherwise, write it. A blank for end-of-record.
   12 FORMAT (A1,$)			!Obviously, not finishing the line each time.
      IF (C.NE.".") GO TO 11	!And if not a full stop, do it again.
      WRITE (MSG,"('')")	!End the line of output.
      GO TO 10		!And have another go.
      END	!That was confusing.


package main

import (
    "bytes"
    "fmt"
    "io"
    "os"
    "unicode"
)

func main() {
    owp(os.Stdout, bytes.NewBufferString("what,is,the;meaning,of:life."))
    fmt.Println()
    owp(os.Stdout, bytes.NewBufferString("we,are;not,in,kansas;any,more."))
    fmt.Println()
}

func owp(dst io.Writer, src io.Reader) {
    byte_in := func () byte {
        bs := make([]byte, 1)
        src.Read(bs)
        return bs[0]
    }
    byte_out := func (b byte) { dst.Write([]byte{b}) }
    var odd func() byte
    odd = func() byte {
        s := byte_in()
        if unicode.IsPunct(rune(s)) {
            return s
        }
        b := odd()
        byte_out(s)
        return b
    }
    for {
        for {
            b := byte_in()
            byte_out(b)
            if b == '.' {
                return
            }
            if unicode.IsPunct(rune(b)) {
                break
            }
        }
        b := odd()
        byte_out(b)
        if b == '.' {
            return
        }
    }
}


import System.IO
       (BufferMode(..), getContents, hSetBuffering, stdin, stdout)
import Data.Char (isAlpha)

split :: String -> (String, String)
split = span isAlpha

parse :: String -> String
parse [] = []
parse l =
  let (a, w) = split l
      (b, x) = splitAt 1 w
      (c, y) = split x
      (d, z) = splitAt 1 y
  in a <> b <> reverse c <> d <> parse z

main :: IO ()
main =
  hSetBuffering stdin NoBuffering >> hSetBuffering stdout NoBuffering >> getContents >>=
  putStr . takeWhile (/= '.') . parse >>
  putStrLn "."


procedure main()
every OddWord(!["what,is,the;meaning,of:life.",
                "we,are;not,in,kansas;any,more."])
end

procedure OddWord(stream)                     #: wrapper for demonstration
   write("Input stream: ",stream)
   writes("Output stream: ") & eWord(create !stream,'.,;:') & write()
end

procedure eWord(stream,marks)                 #: handle even words
   repeat {
      repeat
         writes(@stream) ? if ="." then return else if any(marks) then break
      if writes(oWord(stream,marks)) == '.' then return
      }
end

procedure oWord(stream,marks)                 #: handle odd words (reverse)
   if any(marks,s := @stream) then return s
   return 1(oWord(stream,marks), writes(s))
end


putch=: 4 :0                 NB. coroutine verb
  outch y
  return x
)

isletter=: toupper ~: tolower

do_char=: 3 :0                 NB. coroutine verb
  ch=. getch''
  if. isletter ch do.
    if. odd do.
      putch&ch yield do_char '' return.
    end.
  else.
    odd=: -. odd
  end.
  return ch
)

evenodd=: 3 :0
  clear_outstream begin_instream y
  odd=: 0
  whilst. '.'~:char do.
    outch char=. do_char coroutine ''
  end.
)


public class OddWord {
    interface CharHandler {
	CharHandler handle(char c) throws Exception;
    }
    final CharHandler fwd = new CharHandler() {
	public CharHandler handle(char c) {
	    System.out.print(c);
	    return (Character.isLetter(c) ? fwd : rev);
	}
    };
    class Reverser extends Thread implements CharHandler {
	Reverser() {
	    setDaemon(true);
	    start();
	}
	private Character ch; // For inter-thread comms
	private char recur() throws Exception {
	    notify();
	    while (ch == null) wait();
	    char c = ch, ret = c;
	    ch = null;
	    if (Character.isLetter(c)) {
		ret = recur();
		System.out.print(c);
	    }
	    return ret;
	}
	public synchronized void run() {
	    try {
		while (true) {
		    System.out.print(recur());
		    notify();
		}
	    } catch (Exception e) {}
	}
	public synchronized CharHandler handle(char c) throws Exception {
	    while (ch != null) wait();
	    ch = c;
	    notify();
	    while (ch != null) wait();
	    return (Character.isLetter(c) ? rev : fwd);
	}
    }
    final CharHandler rev = new Reverser();

    public void loop() throws Exception {
	CharHandler handler = fwd;
	int c;
	while ((c = System.in.read()) >= 0) {
	    handler = handler.handle((char) c);
	}
    }

    public static void main(String[] args) throws Exception {
	new OddWord().loop();
    }
}


# io = readstring(STDIN)
io = "what,is,the;meaning,of:life."
i  = 0

readbyte!() = io[global i += 1]
writebyte(c) = print(Char(c))

function odd(prev::Function = () -> false)
    a = readbyte!()
    if !isalpha(a)
        prev()
        writebyte(a)
        return a != '.'
    end

    # delay action until later, in the shape of a closure
    clos() = (writebyte(a); prev())

    return odd(clos)
end

function even()
    while true
        c = readbyte!()
        writebyte(c)
        if !isalpha(c) return c != '.' end
    end
end

evn = false
while evn ? odd() : even()
    evn = !evn
end


// version 1.1.3

typealias Func = () -> Unit

fun doChar(odd: Boolean, f: Func?): Boolean {
    val c = System.`in`.read()
    if (c == -1) return false // end of stream reached
    val ch = c.toChar()

    fun writeOut() {
        print(ch)
        if (f != null) f()
    }

    if (!odd) print(ch)
    if (ch.isLetter()) return doChar(odd, ::writeOut)
    if (odd) {
        if (f != null) f()
        print(ch)
    }
    return ch != '.'
}

fun main(args: Array<String>) {
    repeat(2) {
        var b = true
        while (doChar(!b, null)) b = !b
        System.`in`.read() // remove '\n' from buffer
        println("\n")
    }
}


define odd_word_processor(str::string) => {
	local(
		isodd 		= false,
		pos 		= 1,
		invpos	 	= 1,
		lastpos		= 1
	)
	while(#str->get(#pos) != '.' && #pos <= #str->size) => {
		if(not #str->isAlpha(#pos)) => {
			not #isodd ? #isodd = true | #isodd = false
		}
		if(#isodd) => {
			#lastpos = 1
			#invpos = 1
			while(#str->isAlpha(#pos+#lastpos) && #pos+#lastpos <= #str->size) => {
				#lastpos++
			}
			'odd lastpos: '+#lastpos+'\r'
			local(maxpos = #pos+#lastpos-1)
			while(#invpos < (#lastpos+1)/2) => {
				local(i,o,ipos,opos)
				#ipos = #pos+#invpos
				#opos = #pos+(#lastpos-#invpos)
				#i = #str->get(#ipos)
				#o = #str->get(#opos)

				//'switching '+#i+' and '+#o+'\r'

				//'insert '+#o+' at '+(#ipos)+'\r'
				#str = string_insert(#str,-position=(#ipos),-text=#o)

				//'remove redundant pos '+(#ipos+1)+'\r'
				#str->remove(#ipos+1,1)

				//'insert '+#i+' at '+(#opos)+'\r'
				#str = string_insert(#str,-position=(#opos),-text=#i)

				//'remove redundant pos '+(#opos+1)+'\r'
				#str->remove(#opos+1,1)

				#invpos++
			}
			#pos += #lastpos - 1
		}
		//#str->get(#pos) + #isodd + '\r'
		#pos += 1
	}
	return #str
}

'orig:\rwhat,is,the;meaning,of:life.\r'
'new:\r'
odd_word_processor('what,is,the;meaning,of:life.')
'\rShould have:\rwhat,si,the;gninaem,of:efil.'


function reverse()
  local ch = io.read(1)
  if ch:find("%w") then
    local rc = reverse()
    io.write(ch)
    return rc
  end
  return ch
end

function forward()
  ch = io.read(1)
  io.write(ch)
  if ch == "." then return false end
  if not ch:find("%w") then
    ch = reverse()
    if ch then io.write(ch) end
    if ch == "." then return false end
  end
  return true
end

while forward() do end


Module Checkit {
       global out$
       document out$
      Function PrepareStream$ (buf$) {
            \\ get a temporary file
            if buf$="" then {
                  class ref {
                         f
                  class:
                        module ref (.f) { }
                  }
                  \\ make f closure by reference
                  m->ref(false)
                  =lambda$  m->{
                        if m=>f then exit
                        r$=Key$
                        m=>f=r$="."
                        =r$
                  }
                  \\ exit function
                  break
            }
            name$=tempname$
            \\ we use Ansi type files
            Open name$ for output as F
                  Print #F, buf$;
            Close #F
            Open name$ for input as #f
            class ref {
                   f
            class:
                  module ref (.f) { }
            }
            \\ make f closure by reference
            m->ref(f)
            =lambda$ m -> {
                  if m=>f=-1000 then exit
                  def r$
                  if not eof(#m=>f) then  r$=Input$(#m=>f,2)
                  =r$
                  if r$="" or r$="." then close #m=>f : m=>f=-1000
            }
      }
      Module Odd(c$) {
            one$=""
            Module MyEven(c$, &last$) {
                 one$=If$(last$=""->c$(), last$)
                 if one$="" then exit
                 if not one$ ~"[a-zA-Z]" Then last$=one$: exit
                 \\ print before
                 Print one$;
                 out$<=one$
                 Call MyEven, c$, &last$
            }
            Module MyOdd(c$, &last$) {
                 one$=If$(last$=""->c$(), last$)
                 if one$="" then exit
                 if not one$ ~"[a-zA-Z]" Then last$=one$: exit
                 Call MyOdd, c$, &last$
                 \\ print after
                 Print one$;
                  out$<=one$
            }
            Do {
                  one$=""
                  Call MyEven, c$, &one$
                  if one$="" then exit
                  Print one$;
                  out$<=one$
                  one$=""
                  Call MyOdd, c$, &one$
                  if one$="" then exit
                  Print one$;
                  out$<=one$
            }   Always
            Print
            out$<={
            }
      }
      \\ Feeding keyboard
      keyboard "what,is,the;meaning,of:life."
      Odd PrepareStream$("")
      \\ Use a file for input
      Odd PrepareStream$("we,are;not,in,kansas;any,more.")
      clipboard out$
}
Checkit


import unicode

type Proc = proc(): bool {.closure.}

var nothing: Proc = proc(): bool {.closure.} = false

proc odd(prev = nothing): bool =
  let a = stdin.readChar()
  if not isAlpha(Rune(ord(a))):
    discard prev()
    stdout.write(a)
    return a != '.'

  # delay action until later, in the shape of a closure
  proc clos(): bool =
    stdout.write(a)
    prev()

  return odd(clos)

proc even(): bool =
  while true:
    let c = stdin.readChar()
    stdout.write(c)
    if not isAlpha(Rune(ord(c))):
      return c != '.'

var e = false
while (if e: odd() else: even()):
  e = not e


let is_alpha c =
  c >= 'a' && c <= 'z' ||
  c >= 'A' && c <= 'Z'

let rec odd () =
  let c = input_char stdin in
  if is_alpha c
  then (let e = odd () in print_char c; e)
  else (c)

let rec even () =
  let c = input_char stdin in
  if is_alpha c
  then (print_char c; even ())
  else print_char c

let rev_odd_words () =
  while true do
    even ();
    print_char (odd ())
  done

let () =
  try rev_odd_words ()
  with End_of_file -> ()


(define (odd_word_problem words)
   (letrec ((odd (lambda (s out)
               (let loop ((s s) (l '()))
                  (cond
                     ((null? s)
                        out)
                     ((pair? s)
                        (if (<= #\a (car s) #\z)
                           (loop (cdr s) (cons (car s) l))
                           (even (cdr s) (cons (cons (reverse l) (car s)) out))))
                     (else
                        (loop (s) l))))))
            (even (lambda (s out)
               (let loop ((s s) (l '()))
                  (cond
                     ((null? s)
                        out)
                     ((pair? s)
                        (if (<= #\a (car s) #\z)
                           (loop (cdr s) (cons (car s) l))
                           (odd (cdr s) (cons (cons l (car s)) out))))
                     (else
                        (loop (s) l)))))))
      (for-each (lambda (p)
                  (display (runes->string (car p)))
                  (display (string (cdr p))))
         (reverse
            (odd (str-iter words) '()))))
      (print))
(odd_word_problem "what,is,the;meaning,of:life.")
(odd_word_problem "we,are;not,in,kansas;any,more.")


with javascript_semantics
string s = "what,is,the;meaning,of:life."
--string s = "we,are;not,in,kansas;any,more."
integer i = 0

function getchar()
    i += 1
    return s[i]
end function

function wrod(integer rev)
    integer ch = getchar(), nch
--  integer ch = getc(0), nch
    if not find(ch," .,:;!?") then
        if rev then
            nch = wrod(rev)
        end if
        puts(1,ch)
        if not rev then
            nch = wrod(rev)
        end if
        ch = nch
    end if
    return ch
end function

--puts(1,"Enter words separated by a single punctuation mark (i.e. !?,.;:) and ending with .\n")
integer rev = 0
while 1 do
    integer ch = wrod(rev)
    puts(1,ch)
    if ch='.' then exit end if
    rev = 1-rev
end while


$odd = function ($prev) use ( &$odd ) {
	$a = fgetc(STDIN);
	if (!ctype_alpha($a)) {
		$prev();
		fwrite(STDOUT, $a);
		return $a != '.';
	}
	$clos = function () use ($a , $prev) {
		fwrite(STDOUT, $a);
		$prev();
	};
	return $odd($clos);
};
$even = function () {
	while (true) {
		$c = fgetc(STDIN);
		fwrite(STDOUT, $c);
		if (!ctype_alpha($c)) {
			return $c != ".";
		}
	}
};
$prev = function(){};
$e = false;
while ($e ? $odd($prev) : $even()) {
	$e = !$e;
}


(de oddWords ()
   (use C
      (loop
         (until (sub? (prin (setq C (char))) "!,.:;?"))
         (T (= "." C))
         (setq C (char))
         (T
            (= "."
               (prin
                  (recur (C)
                     (if (sub? C "!,.:;?")
                        C
                        (prog1 (recurse (char)) (prin C)) ) ) ) ) ) )
   (prinl) ) )


test: procedure options (main);  /* 2 August 2014 */
   declare (ch, ech) character (1);
   declare odd file;

get_word: procedure recursive;
   declare ch character (1);

   get file (odd) edit (ch) (a(1));
   if index('abcdefghijklmnopqrstuvwxyz', ch) > 0 then call get_word;
   if index('abcdefghijklmnopqrstuvwxyz', ch) > 0 then
      put edit (ch) (a);
   else ech = ch;
end get_word;

   open file (odd) input title ('/ODDWORD.DAT,TYPE(text),recsize(100)');
   do forever;
      do  until (index('abcdefghijklmnopqrstuvwxyz', ch) = 0 );
         get file (odd) edit (ch) (a(1)); put edit (ch) (a);
      end;
      if ch = '.' then leave;
      call get_word;
      put edit (ech) (a);
      if ech = '.' then leave;
   end;
end test;


odd_word_problem :-
	read_line_to_codes(user_input, L),
	even_word(L, Out, []),
	string_to_list(Str, Out),
	writeln(Str).

even_word(".") --> ".".

even_word([H | T]) -->
	{char_type(H,alnum)},
	[H],
	even_word(T).

even_word([H | T]) -->
	[H],
	odd_word(T, []).

odd_word(".", R) --> R, ".".

odd_word([H|T], R) -->
	{char_type(H,alnum)},
	odd_word(T, [H | R]).

odd_word([H|T], R) -->
	R,
	[H],
	even_word(T).


#False = 0
#True = 1

Global *inputPtr.Character

Macro nextChar()
  *inputPtr + SizeOf(Character)
EndMacro

Procedure isPunctuation(c.s)
  If FindString("!?()[]{},.;:-'" + #DQUOTE$, c)
    ProcedureReturn #True
  EndIf
  ProcedureReturn #False
EndProcedure

Procedure oddWord()
  Protected c.c
  c = *inputPtr\c
  If isPunctuation(Chr(*inputPtr\c))
    ProcedureReturn
  Else
    nextChar()
    oddWord()
  EndIf
  Print(Chr(c))
EndProcedure

Procedure oddWordProblem(inputStream.s)
  *inputPtr = @inputStream
  Define isOdd = #False
  While *inputPtr\c
    If isOdd
      oddWord()
    Else
      Repeat
        Print(Chr(*inputPtr\c))
        nextChar()
      Until isPunctuation(Chr(*inputPtr\c))
    EndIf
    Print(Chr(*inputPtr\c))
    isOdd ! 1 ;toggle word indicator
    nextChar()
  Wend
EndProcedure

Define inputStream.s
If OpenConsole()
  Repeat
    PrintN(#CRLF$ + #CRLF$ + "Enter a series of words consisting only of English letters (i.e. a-z, A-Z)")
    PrintN("and that are separated by a punctuation mark (i.e. !?()[]{},.;:-' or " + #DQUOTE$ + ").")
    inputStream = Input()
    oddWordProblem(inputStream) ;assume input is correct
  Until inputStream = ""

  Print(#CRLF$ + #CRLF$ + "Press ENTER to exit"): Input()
  CloseConsole()
EndIf


from sys import stdin, stdout

def char_in(): return stdin.read(1)
def char_out(c): stdout.write(c)

def odd(prev = lambda: None):
	a = char_in()
	if not a.isalpha():
		prev()
		char_out(a)
		return a != '.'

	# delay action until later, in the shape of a closure
	def clos():
		char_out(a)
		prev()

	return odd(clos)

def even():
	while True:
		c = char_in()
		char_out(c)
		if not c.isalpha(): return c != '.'

e = False
while odd() if e else even():
	e = not e


[ upper dup lower != ] is letter    ( c --> b )

               forward is backwords ( $ --> $ )

[ [ behead
    dup letter while
    emit again ]
  dup emit
  char . !=
  if backwords ]       is forwords  ( $ --> $ )

[ [ behead
    dup letter while
    swap recurse
    rot emit ]
  dup emit
  char . !=
  if forwords ]  resolves backwords ( $ --> $ )

[ forwords drop cr ]   is oddwords  ( $ -->   )

$ "we,are;not,in,kansas;any,more." oddwords
$ "what,is,the;meaning,of:life."   oddwords


#!/bin/sh
#|
exec racket -tm- "$0" "[email protected]"
|#

#lang racket

(define (even k)
  (define c (read-char))
  (cond [(eq? c eof) (k)]
        [(not (char-alphabetic? c)) (k) (write-char c) (odd)]
        [else (even (λ() (write-char c) (k)))]))

(define (odd)
  (define c (read-char))
  (unless (eq? c eof)
    (write-char c)
    (if (char-alphabetic? c) (odd) (even void))))

(provide main)
(define (main) (odd) (newline))

;; (with-input-from-string "what,is,the;meaning,of:life." main)
;; ;; -> what,si,the;gninaem,of:efil.
;; (with-input-from-string "we,are;not,in,kansas;any,more." main)
;; ;; -> we,era;not,ni,kansas;yna,more.


my &in = { $*IN.getc // last }

loop {
    ew(in);
    ow(in).print;
}

multi ew ($_ where /\w/) { .print; ew(in); }
multi ew ($_)            { .print; next when "\n"; }

multi ow ($_ where /\w/) { ow(in) x .print; }
multi ow ($_)            { $_; }


/*REXX program solves the  odd word problem  by only using  (single) byte  input/output.*/
                           iFID_ = 'ODDWORD.IN'  /*Note:  numeric suffix is added later.*/
                           oFID_ = 'ODDWORD.'    /*  "       "       "    "   "     "   */
     do case=1  for 2;                #= 0       /*#:  is the number of characters read.*/
     iFID= iFID_  ||  case                       /*read   ODDWORD.IN1  or  ODDWORD.IN2  */
     oFID= oFID_  ||  case                       /*write  ODDWORD.1    or  ODDWORD.2    */
     say;   say;    say '════════ reading file: '        iFID        "════════"                /* ◄■■■■■■■■■ optional. */

         do  until x==.                          /* [↓]  perform until reaching a period*/
                do  until \datatype(x, 'M')      /* [↓]     "      "   punctuation found*/
                call rChar                       /*read  a single character.            */
                call wChar                       /*write "    "       "                 */
                end   /*until \data···*/         /* [↑]  read/write until punctuation.  */
         if x==.  then leave                     /*is this the end─of─sentence (period)?*/
         call readLetters;            punct= #   /*save the location of the punctuation.*/
                do j=#-1  by -1                  /*read some characters backwards.      */
                call rChar j                     /*read previous word (backwards).      */
                if \datatype(x, 'M')  then leave /*Found punctuation?   Then leave  J.  */
                call wChar                       /*write a character (which is a letter)*/
                end   /*j*/                      /* [↑]  perform for  "even"  words.    */
         call rLett                              /*read letters until punctuation found.*/
         call wChar;                  #= punct   /*write a char;  punctuation location. */
         end      /*until x==.*/
     end          /*case*/                       /* [↑]  process both of the input files*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
rLett: do  until  \datatype(x, 'M');         call rChar;             end;         return
wChar: call charout , x  /*console*/;        call charout oFID, x  /*file*/;      return
/*──────────────────────────────────────────────────────────────────────────────────────*/
rChar: if arg()==0  then do; x= charin(iFID); #= #+1; end  /*read  next  char*/
                    else     x= charin(iFID, arg(1) );     /*  " specific  " */   return


# Project : Odd word problem

test = "what,is,the;meaning,of:life."
n1 = 1
testarr = []
testorigin = test
test = substr(test, ",", " ")
test = substr(test, ";", " ")
test = substr(test, ":", " ")
test = substr(test, ".", " ")

while true
      n2 = substring(test, " ", n1)
      n3 = substring(test, " ", n2 + 1)
      if n2>0 and n3>0
         strcut = substr(test, n2 + 1, n3 - n2)
         strcut = trim(strcut)
         if strcut != ""
            add(testarr, strcut)
            n1 = n3 + 1
         else
            exit
         ok
      ok
end

for n = 1 to len(testarr)
    strrev = revstr(testarr[n])
    testorigin = substr(testorigin, testarr[n], strrev)
next
see testorigin + nl

func Substring str,substr,n
     newstr=right(str,len(str)-n+1)
     nr = substr(newstr, substr)
     return n + nr -1

func revstr(cStr)
     cStr2 = ""
     for x = len(cStr) to 1 step -1
         cStr2 += cStr[x]
     next
     return cStr2


f, r = nil
fwd = proc {|c|
  c =~ /[[:alpha:]]/ ? [(print c), fwd[Fiber.yield f]][1] : c }
rev = proc {|c|
  c =~ /[[:alpha:]]/ ? [rev[Fiber.yield r], (print c)][0] : c }

(f = Fiber.new { loop { print fwd[Fiber.yield r] }}).resume
(r = Fiber.new { loop { print rev[Fiber.yield f] }}).resume

coro = f
until $stdin.eof?
  coro = coro.resume($stdin.getc)
end


open "oddWord.txt" for input as #f               ' read input stream
while not(eof(#f))
line input #f, a$
oddW$  = ""                                      ' begin the result oddW with blank
px     = 0                                       ' begin word search location with 0
count  = 0                                       ' begin the word count to 0
while x < len(a$)                                ' look at each character
	x    = instr(a$,",",px)                  ' search for comma (,)
	if x = 0 then x = len(a$)                ' no more commas?
	x1   = instr(a$,";",px)                  ' search for (;)
	x2   = instr(a$,":",px)                  ' search for (:)
	if x1 <> 0 then x = min(x,x1)            ' what came first the , ; or :
	if x2 <> 0 then x = min(x,x2)

	w$  = mid$(a$,px,x - px)                 ' get the word seperated by , ; or :

	if count and 1 then                      ' is it the odd word
	        w1$ = ""
		for i = len(w$) to 1 step -1
			w1$ = w1$ + mid$(w$,i,1) ' reverse odd words
		next i
		w$ = w1$
	end if
        oddW$ = oddW$ + w$ + mid$(a$,x,1)        ' add the word to the end of oddW$
	px    = x + 1                            ' bump word search location for next while
	count = count + 1                        ' count the words
wend
print a$;" -> ";oddW$                            ' print the original and result
next ii
wend
close #f


import scala.io.Source
import java.io.PrintStream

def process(s: Source, p: PrintStream, w: Int = 0): Unit = if (s.hasNext) s.next match {
  case '.' => p append '.'
  case c if !Character.isAlphabetic(c) => p append c; reverse(s, p, w + 1)
  case c => p append c; process(s, p, w)
}

def reverse(s: Source, p: PrintStream, w: Int = 0, x: Char = '.'): Char = s.next match {
  case c if !Character.isAlphabetic(c) => p append x; c
  case c => val n = reverse(s, p, w, c);
    if (x == '.') {p append n; process(s, p, w + 1)} else p append x; n
}

process(Source.fromString("what,is,the;meaning,of:life."), System.out); println
process(Source.fromString("we,are;not,in,kansas;any,more."), System.out); println


(define (odd)
  (let ((c (read-char)))
    (if (char-alphabetic? c)
      (let ((r (odd)))
	(write-char c)
	r)
      (lambda () (write-char c) (char=? c #\.)))))

(define (even)
  (let ((c (read-char)))
    (write-char c)
    (if (char-alphabetic? c)
      (even)
      (char=? c #\.))))

(let loop ((i #f))
  (if (if i ((odd)) (even))
    (exit)
    (loop (not i))))


$ include "seed7_05.s7i";
  include "chartype.s7i";

const func char: doChar (in boolean: doReverse) is func
  result
    var char: delimiter is ' ';
  local
    var char: ch is ' ';
  begin
    ch := getc(IN);
    if ch in letter_char then
      if doReverse then
        delimiter := doChar(doReverse);
        write(ch);
      else
        write(ch);
        delimiter := doChar(doReverse);
      end if;
    else
      delimiter := ch;
    end if;
  end func;

const proc: main is func
  local
    var char: delimiter is ' ';
    var boolean: doReverse is FALSE;
  begin
    repeat
      delimiter := doChar(doReverse);
      write(delimiter);
      doReverse := not doReverse;
    until delimiter = '.';
    writeln;
  end func;


func rev {
    (var c = STDIN.getc) \\ return()
    if (c ~~ /^[a-z]\z/i) {
        var r = rev()
        print c
        return r
    }
    return c
}

var (n=0, l=false)
while (defined(var c = STDIN.getc)) {
    var w = (c ~~ /^[a-z]\z/i)
    ++n if (w && !l)
    l = w
    if (n & 1) {
        print c
    } else {
        var r = rev()
        print(c, r)
        n = 0
        l = false
    }
}


package require Tcl 8.6

proc fwd c {
    expr {[string is alpha $c] ? "[fwd [yield f][puts -nonewline $c]]" : $c}
}
proc rev c {
    expr {[string is alpha $c] ? "[rev [yield r]][puts -nonewline $c]" : $c}
}
coroutine f while 1 {puts -nonewline [fwd [yield r]]}
coroutine r while 1 {puts -nonewline [rev [yield f]]}
for {set coro f} {![eof stdin]} {} {
    set coro [$coro [read stdin 1]]
}


$$ MODE TUSCRIPT
inputstring=*
DATA what,is,the;meaning,of:life.
DATA we,are;not,in,kansas;any,more.

BUILD C_GROUP >[pu]=".,;:-"

LOOP i=inputstring
pu=STRINGS (i,"|>[pu]|")
wo=STRINGS (i,"|<></|")
outputstring=""
 loop n,w=wo,p=pu
 r=MOD(n,2)
 IF (r==0) w=TURN (w)
 outputstring=CONCAT(outputstring,w,p)
ENDLOOP
PRINT outputstring
ENDLOOP


Private Function OddWordFirst(W As String) As String
Dim i As Integer, count As Integer, l As Integer, flag As Boolean, temp As String
   count = 1
   Do
      flag = Not flag
      l = FindNextPunct(i, W) - count + 1
      If flag Then
         temp = temp & ExtractWord(W, count, l)
      Else
         temp = temp & ReverseWord(W, count, l)
      End If
   Loop While count < Len(W)
   OddWordFirst = temp
End Function

Private Function FindNextPunct(d As Integer, W As String) As Integer
Const PUNCT As String = ",;:."
   Do
      d = d + 1
   Loop While InStr(PUNCT, Mid(W, d, 1)) = 0
   FindNextPunct = d
End Function

Private Function ExtractWord(W As String, c As Integer, i As Integer) As String
   ExtractWord = Mid(W, c, i)
   c = c + Len(ExtractWord)
End Function

Private Function ReverseWord(W As String, c As Integer, i As Integer) As String
Dim temp As String, sep As String
   temp = Left(Mid(W, c, i), Len(Mid(W, c, i)) - 1)
   sep = Right(Mid(W, c, i), 1)
   ReverseWord = StrReverse(temp) & sep
   c = c + Len(ReverseWord)
End Function


import "io" for Stdin,Stdout
import "/str" for Char

var fwrite = Fn.new { |ch|
    System.write(ch)
    Stdout.flush()
}

var doChar // recursive
doChar = Fn.new { |odd, f|
    var c = Stdin.readByte()
    if (!c) return false // end of stream reached
    var ch = String.fromByte(c)

    var writeOut = Fn.new {
        fwrite.call(ch)
        if (f) f.call()
    }

    if (!odd) fwrite.call(ch)
    if (Char.isLetter(ch)) return doChar.call(odd, writeOut)
    if (odd) {
        if (f) f.call()
        fwrite.call(ch)
    }
    return ch != "."
}

for (i in 0..1) {
    var b = true
    while (doChar.call(!b, null)) b = !b
    Stdin.readByte() // remove \n from buffer
    System.print("\n")
}


var [const] delim=",:;/[email protected]#$%^&*()_+", stop=".";
fcn oddly(inStream){
   inStream=inStream.walker(3);  // character iterator: string, file, etc
   doWord:=fcn(inStream,rev,f){  // print next word forewards or reverse
      c:=inStream.next();
      if(not rev) c.print();
      if(not (c==stop or delim.holds(c)))
	 return(self.fcn(inStream,rev,'{ c.print(); f(); }));
      if(rev){ f(); c.print(); }
      return(c!=stop);
   };
   tf:=Walker.cycle(False,True);  // every other word printed backwords
   while(doWord(inStream, tf.next(), Void)) {}
   println();
}


F legendreIn(x, n)
   F prev1(idx, pn1)
      R (2 * idx - 1) * @x * pn1
   F prev2(idx, pn2)
      R (idx - 1) * pn2

   I n == 0
      R 1.0
   E I n == 1
      R x
   E
      V result = 0.0
      V p1 = x
      V p2 = 1.0
      L(i) 2 .. n
         result = (prev1(i, p1) - prev2(i, p2)) / i
         p2 = p1
         p1 = result
      R result

F deriveLegendreIn(x, n)
   F calcresult(curr, prev)
      R Float(@n) / (@x ^ 2 - 1) * (@x * curr - prev)
   R calcresult(legendreIn(x, n), legendreIn(x, n - 1))

F guess(n, i)
   R cos(math:pi * (i - 0.25) / (n + 0.5))

F nodes(n)
   V result = [(0.0, 0.0)] * n
   F calc(x)
      R legendreIn(x, @n) / deriveLegendreIn(x, @n)

   L(i) 0 .< n
      V x = guess(n, i + 1)
      V x0 = x
      x -= calc(x)
      L abs(x - x0) > 1e-12
         x0 = x
         x -= calc(x)

      result[i] = (x, 2 / ((1.0 - x ^ 2) * (deriveLegendreIn(x, n)) ^ 2))

   R result

F integ(f, ns, p1, p2)
   F dist()
      R (@p2 - @p1) / 2
   F avg()
      R (@p1 + @p2) / 2
   V result = dist()
   V sum = 0.0
   V thenodes = [0.0] * ns
   V weights  = [0.0] * ns
   L(nw) nodes(ns)
      sum += nw[1] * f(dist() * nw[0] + avg())
      thenodes[L.index] = nw[0]
      weights[L.index] = nw[1]

   print(‘   nodes:’, end' ‘’)
   L(n) thenodes
      print(‘ #.5’.format(n), end' ‘’)
   print()
   print(‘ weights:’, end' ‘’)
   L(w) weights
      print(‘ #.5’.format(w), end' ‘’)
   print()
   R result * sum

print(‘integral: ’integ(x -> exp(x), 5, -3, 3))


NNI ==> NonNegativeInteger
RECORD ==> Record(x : List Fraction Integer, w : List Fraction Integer)

gaussCoefficients(n : NNI, eps : Fraction Integer) : RECORD ==
  p := legendreP(n,z)
  q := n/2*D(p, z)*legendreP(subtractIfCan(n,1)::NNI, z)
  x := map(rhs,solve(p,eps))
  w := [subst(1/q, z=xi) for xi in x]
  [x,w]

gaussIntegrate(e : Expression Float, segbind : SegmentBinding(Float), n : NNI) : Float ==
  eps := 1/10^100
  u := gaussCoefficients(n,eps)
  interval := segment segbind
  var := variable segbind
  a := lo interval
  b := hi interval
  c := (a+b)/2
  h := (b-a)/2
  h*reduce(+,[wi*subst(e,var=c+xi*h) for xi in u.x for wi in u.w])


#include <stdio.h>
#include <math.h>

#define N 5
double Pi;
double lroots[N];
double weight[N];
double lcoef[N + 1][N + 1] = {{0}};

void lege_coef()
{
	int n, i;
	lcoef[0][0] = lcoef[1][1] = 1;
	for (n = 2; n <= N; n++) {
		lcoef[n][0] = -(n - 1) * lcoef[n - 2][0] / n;
		for (i = 1; i <= n; i++)
			lcoef[n][i] = ((2 * n - 1) * lcoef[n - 1][i - 1]
					 - (n - 1) * lcoef[n - 2][i] ) / n;
	}
}

double lege_eval(int n, double x)
{
	int i;
	double s = lcoef[n][n];
	for (i = n; i; i--)
		s = s * x + lcoef[n][i - 1];
	return s;
}

double lege_diff(int n, double x)
{
	return n * (x * lege_eval(n, x) - lege_eval(n - 1, x)) / (x * x - 1);
}

void lege_roots()
{
	int i;
	double x, x1;
	for (i = 1; i <= N; i++) {
		x = cos(Pi * (i - .25) / (N + .5));
		do {
			x1 = x;
			x -= lege_eval(N, x) / lege_diff(N, x);
		} while ( fdim( x, x1) > 2e-16 );
		/*  fdim( ) was introduced in C99, if it isn't available
		 *  on your system, try fabs( ) */
		lroots[i - 1] = x;

		x1 = lege_diff(N, x);
		weight[i - 1] = 2 / ((1 - x * x) * x1 * x1);
	}
}

double lege_inte(double (*f)(double), double a, double b)
{
	double c1 = (b - a) / 2, c2 = (b + a) / 2, sum = 0;
	int i;
	for (i = 0; i < N; i++)
		sum += weight[i] * f(c1 * lroots[i] + c2);
	return c1 * sum;
}

int main()
{
	int i;
	Pi = atan2(1, 1) * 4;

	lege_coef();
	lege_roots();

	printf("Roots: ");
	for (i = 0; i < N; i++)
		printf(" %g", lroots[i]);

	printf("\nWeight:");
	for (i = 0; i < N; i++)
		printf(" %g", weight[i]);

	printf("\nintegrating Exp(x) over [-3, 3]:\n\t%10.8f,\n"
		"compred to actual\n\t%10.8f\n",
		lege_inte(exp, -3, 3), exp(3) - exp(-3));
	return 0;
}


#include <iostream>
#include <iomanip>
#include <cmath>

namespace Rosetta {

    /*! Implementation of Gauss-Legendre quadrature
    *  http://en.wikipedia.org/wiki/Gaussian_quadrature
    *  http://rosettacode.org/wiki/Numerical_integration/Gauss-Legendre_Quadrature
    *
    */
    template <int N>
    class GaussLegendreQuadrature {
    public:
        enum {eDEGREE = N};

        /*! Compute the integral of a functor
        *
        *   @param a    lower limit of integration
        *   @param b    upper limit of integration
        *   @param f    the function to integrate
        *   @param err  callback in case of problems
        */
        template <typename Function>
        double integrate(double a, double b, Function f) {
            double p = (b - a) / 2;
            double q = (b + a) / 2;
            const LegendrePolynomial& legpoly = s_LegendrePolynomial;

            double sum = 0;
            for (int i = 1; i <= eDEGREE; ++i) {
                sum += legpoly.weight(i) * f(p * legpoly.root(i) + q);
            }

            return p * sum;
        }

        /*! Print out roots and weights for information
        */
        void print_roots_and_weights(std::ostream& out) const {
            const LegendrePolynomial& legpoly = s_LegendrePolynomial;
            out << "Roots:  ";
            for (int i = 0; i <= eDEGREE; ++i) {
                out << ' ' << legpoly.root(i);
            }
            out << std::endl;
            out << "Weights:";
            for (int i = 0; i <= eDEGREE; ++i) {
                out << ' ' << legpoly.weight(i);
            }
            out << std::endl;
        }
    private:
        /*! Implementation of the Legendre polynomials that form
        *   the basis of this quadrature
        */
        class LegendrePolynomial {
        public:
            LegendrePolynomial () {
                // Solve roots and weights
                for (int i = 0; i <= eDEGREE; ++i) {
                    double dr = 1;

                    // Find zero
                    Evaluation eval(cos(M_PI * (i - 0.25) / (eDEGREE + 0.5)));
                    do {
                        dr = eval.v() / eval.d();
                        eval.evaluate(eval.x() - dr);
                    } while (fabs (dr) > 2e-16);

                    this->_r[i] = eval.x();
                    this->_w[i] = 2 / ((1 - eval.x() * eval.x()) * eval.d() * eval.d());
                }
            }

            double root(int i) const { return this->_r[i]; }
            double weight(int i) const { return this->_w[i]; }
        private:
            double _r[eDEGREE + 1];
            double _w[eDEGREE + 1];

            /*! Evaluate the value *and* derivative of the
            *   Legendre polynomial
            */
            class Evaluation {
            public:
                explicit Evaluation (double x) : _x(x), _v(1), _d(0) {
                    this->evaluate(x);
                }

                void evaluate(double x) {
                    this->_x = x;

                    double vsub1 = x;
                    double vsub2 = 1;
                    double f     = 1 / (x * x - 1);

                    for (int i = 2; i <= eDEGREE; ++i) {
                        this->_v = ((2 * i - 1) * x * vsub1 - (i - 1) * vsub2) / i;
                        this->_d = i * f * (x * this->_v - vsub1);

                        vsub2 = vsub1;
                        vsub1 = this->_v;
                    }
                }

                double v() const { return this->_v; }
                double d() const { return this->_d; }
                double x() const { return this->_x; }

            private:
                double _x;
                double _v;
                double _d;
            };
        };

        /*! Pre-compute the weights and abscissae of the Legendre polynomials
        */
        static LegendrePolynomial s_LegendrePolynomial;
    };

    template <int N>
    typename GaussLegendreQuadrature<N>::LegendrePolynomial GaussLegendreQuadrature<N>::s_LegendrePolynomial;
}

// This to avoid issues with exp being a templated function
double RosettaExp(double x) {
    return exp(x);
}

int main() {
    Rosetta::GaussLegendreQuadrature<5> gl5;

    std::cout << std::setprecision(10);

    gl5.print_roots_and_weights(std::cout);
    std::cout << "Integrating Exp(X) over [-3, 3]: " << gl5.integrate(-3., 3., RosettaExp) << std::endl;
    std::cout << "Actual value:                    " << RosettaExp(3) - RosettaExp(-3) << std::endl;
}


using System;
//Works in .NET 6+
//Tested using https://dotnetfiddle.net because im lazy

public class Program {

    public static double[][] legeCoef(int N) {
        //Initialising Jagged Array
        double[][] lcoef = new double[N+1][];
        for (int i=0; i < lcoef.Length; ++i)
            lcoef[i] = new double[N+1];

        lcoef[0][0] = lcoef[1][1] = 1;
        for (int n = 2; n <= N; n++) {
            lcoef[n][0] = -(n - 1) * lcoef[n - 2][0] / n;
            for (int i = 1; i <= n; i++)
                lcoef[n][i] = ((2*n - 1) * lcoef[n-1][i-1]
                               - (n-1) * lcoef[n-2][i] ) / n;
        }
        return lcoef;
    }

    static double legeEval(double[][] lcoef, int N, double x) {
        double s = lcoef[N][N];
        for (int i = N; i > 0; --i)
            s = s * x + lcoef[N][i-1];
        return s;
    }

    static double legeDiff(double[][] lcoef, int N, double x) {
        return N * (x * legeEval(lcoef, N, x) - legeEval(lcoef, N-1, x)) / (x*x - 1);
    }

    static void legeRoots(double[][] lcoef, int N, out double[] lroots,  out double[] weight) {
        lroots = new double[N];
        weight = new double[N];

        double x, x1;
        for (int i = 1; i <= N; i++) {
            x = Math.Cos(Math.PI * (i - 0.25) / (N + 0.5));
            do {
                x1 = x;
                x -= legeEval(lcoef, N, x) / legeDiff(lcoef, N, x);
            }
            while (x != x1);
            lroots[i-1] = x;

            x1 = legeDiff(lcoef, N, x);
            weight[i-1] = 2 / ((1 - x*x) * x1*x1);
        }
    }

    static double legeInte(Func<Double, Double> f, int N, double[] weights, double[] lroots, double a, double b) {
        double c1 = (b - a) / 2, c2 = (b + a) / 2, sum = 0;
        for (int i = 0; i < N; i++)
            sum += weights[i] * f.Invoke(c1 * lroots[i] + c2);
        return c1 * sum;
    }

    //..................Main...............................
    public static string Combine(double[] arrayD) {
        return string.Join(", ", arrayD);
    }

    public static void Main() {
        int N = 5;

        var lcoeff = legeCoef(N);

        double[] roots;
        double[] weights;
        legeRoots(lcoeff, N, out roots, out weights);

        var integrateResult = legeInte(x=>Math.Exp(x), N, weights, roots, -3, 3);

        Console.WriteLine("Roots:   " + Combine(roots));
        Console.WriteLine("Weights: " + Combine(weights)+ "\n" );
        Console.WriteLine("integral: " + integrateResult );
        Console.WriteLine("actual:   " + (Math.Exp(3)-Math.Exp(-3)) );
    }

}


;; Computes the initial guess for the root i of a n-order Legendre polynomial.
(defun guess (n i)
  (cos (* pi
          (/ (- i 0.25d0)
             (+ n 0.5d0)))))

;; Computes and evaluates the n-order Legendre polynomial at the point x.
(defun legpoly (n x)
  (let ((pa 1.0d0)
        (pb x)
        (pn))
    (cond ((= n 0) pa)
          ((= n 1) pb)
          (t (loop for i from 2 to n do
                  (setf pn (- (* (/ (- (* 2 i) 1) i) x pb)
                              (* (/ (- i 1) i) pa)))
                  (setf pa pb)
                  (setf pb pn)
                  finally (return pn))))))

;; Computes and evaluates the derivative of an n-order Legendre polynomial at point x.
(defun legdiff (n x)
  (* (/ n (- (* x x) 1))
     (- (* x (legpoly n x))
        (legpoly (- n 1) x))))

;; Computes the n nodes for an n-point quadrature rule. (i.e. n roots of a n-order polynomial)
(defun nodes (n)
  (let ((x (make-array n :initial-element 0.0d0)))
    (loop for i from 0 to (- n 1) do
         (let ((val (guess n (+ i 1))) ;Nullstellen-Schätzwert.
               (itermax 5))
           (dotimes (j itermax)
             (setf val (- val
                          (/ (legpoly n val)
                             (legdiff n val)))))
           (setf (aref x i) val)))
    x))

;; Computes the weight for an n-order polynomial at the point (node) x.
(defun legwts (n x)
  (/ 2
     (* (- 1 (* x x))
        (expt (legdiff n x) 2))))

;; Takes a array of nodes x and computes an array of corresponding weights w.
(defun weights (x)
  (let* ((n (car (array-dimensions x)))
         (w (make-array n :initial-element 0.0d0)))
    (loop for i from 0 to (- n 1) do
         (setf (aref w i) (legwts n (aref x i))))
    w))

;; Integrates a function f with a n-point Gauss-Legendre quadrature rule over the interval [a,b].
(defun int (f n a b)
  (let* ((x (nodes n))
         (w (weights x)))
    (* (/ (- b a) 2.0d0)
       (loop for i from 0 to (- n 1)
          sum (* (aref w i)
                 (funcall f (+ (* (/ (- b a) 2.0d0)
                                  (aref x i))
                               (/ (+ a b) 2.0d0))))))))


import std.stdio, std.math;

immutable struct GaussLegendreQuadrature(size_t N, FP=double,
                                         size_t NBITS=50) {
    immutable static double[N] lroots, weight;
    alias FP[N + 1][N + 1] CoefMat;

    pure nothrow @safe @nogc static this() {
        static FP legendreEval(in ref FP[N + 1][N + 1] lcoef,
                               in int n, in FP x) pure nothrow {
            FP s = lcoef[n][n];
            foreach_reverse (immutable i; 1 .. n+1)
                s = s * x + lcoef[n][i - 1];
            return s;
        }

        static FP legendreDiff(in ref CoefMat lcoef,
                               in int n, in FP x)
        pure nothrow @safe @nogc {
            return n * (x * legendreEval(lcoef, n, x) -
                        legendreEval(lcoef, n - 1, x)) /
                   (x ^^ 2 - 1);
        }

        CoefMat lcoef = 0.0;
        legendreCoefInit(/*ref*/ lcoef);

        // Legendre roots:
        foreach (immutable i; 1 .. N + 1) {
            FP x = cos(PI * (i - 0.25) / (N + 0.5));
            FP x1;
            do {
                x1 = x;
                x -= legendreEval(lcoef, N, x) /
                     legendreDiff(lcoef, N, x);
            } while (feqrel(x, x1) < NBITS);
            lroots[i - 1] = x;
            x1 = legendreDiff(lcoef, N, x);
            weight[i - 1] = 2 / ((1 - x ^^ 2) * (x1 ^^ 2));
        }
    }

    static private void legendreCoefInit(ref CoefMat lcoef)
    pure nothrow @safe @nogc {
        lcoef[0][0] = lcoef[1][1] = 1;
        foreach (immutable int n; 2 .. N + 1) { // n must be signed.
            lcoef[n][0] = -(n - 1) * lcoef[n - 2][0] / n;
            foreach (immutable i; 1 .. n + 1)
                lcoef[n][i] = ((2 * n - 1) * lcoef[n - 1][i - 1] -
                               (n - 1) * lcoef[n - 2][i]) / n;
        }
    }

    static public FP integrate(in FP function(/*in*/ FP x) pure nothrow @safe @nogc f,
                               in FP a, in FP b)
    pure nothrow @safe @nogc {
        immutable FP c1 = (b - a) / 2;
        immutable FP c2 = (b + a) / 2;
        FP sum = 0.0;
        foreach (immutable i; 0 .. N)
            sum += weight[i] * f(c1 * lroots[i] + c2);
        return c1 * sum;
    }
}

void main() {
    GaussLegendreQuadrature!(5, real) glq;
    writeln("Roots:  ", glq.lroots);
    writeln("Weight: ", glq.weight);
    writefln("Integrating exp(x) over [-3, 3]: %10.12f",
             glq.integrate(&exp, -3, 3));
    writefln("Compred to actual:               %10.12f",
             3.0.exp - exp(-3.0));
}


program Legendre;

{$APPTYPE CONSOLE}

const Order   = 5;
      Epsilon = 1E-12;

var Roots   : array[0..Order-1] of double;
    Weight  : array[0..Order-1] of double;
    LegCoef : array [0..Order,0..Order] of double;

function F(X:double) : double;
begin
  Result := Exp(X);
end;

procedure PrepCoef;
var I, N : integer;
begin
  for I:=0 to Order do
    for N := 0 to Order do
      LegCoef[I,N] := 0;
  LegCoef[0,0] := 1;
  LegCoef[1,1] := 1;
  For N:=2 to Order do
    begin
      LegCoef[N,0] := -(N-1) * LegCoef[N-2,0] / N;
      For I := 1 to Order do
        LegCoef[N,I] := ((2*N-1) * LegCoef[N-1,I-1] - (N-1)*LegCoef[N-2,I]) / N;
    end;
end;

function LegEval(N:integer; X:double) : double;
var I : integer;
begin
  Result := LegCoef[n][n];
  for I := N-1 downto 0 do
    Result := Result * X + LegCoef[N][I];
end;

function LegDiff(N:integer; X:double) : double;
begin
  Result := N * (X * LegEval(N,X) - LegEval(N-1,X)) / (X*X-1);
end;

procedure LegRoots;
var I     : integer;
    X, X1 : double;
begin
  for I := 1 to Order do
    begin
      X := Cos(Pi * (I-0.25) / (Order+0.5));
        repeat
          X1 := X;
          X := X - LegEval(Order,X) / LegDiff(Order, X);
        until Abs (X-X1) < Epsilon;
      Roots[I-1] := X;
      X1 := LegDiff(Order,X);
      Weight[I-1] := 2 / ((1-X*X) * X1*X1);
    end;
end;

function LegInt(A,B:double) : double;
var I      : integer;
    C1, C2 : double;
begin
  C1 := (B-A)/2;
  C2 := (B+A)/2;
  Result := 0;
  For I := 0 to Order-1 do
    Result := Result + Weight[I] * F(C1*Roots[I] + C2);
  Result := C1 * Result;
end;

var I : integer;

begin
  PrepCoef;
  LegRoots;

  Write('Roots:  ');
  for I := 0 to Order-1 do
    Write (' ',Roots[I]:13:10);
  Writeln;

  Write('Weight: ');
  for I := 0 to Order-1 do
    Write (' ', Weight[I]:13:10);
  writeln;

  Writeln('Integrating Exp(x) over [-3, 3]: ',LegInt(-3,3):13:10);
  Writeln('Actual value: ',Exp(3)-Exp(-3):13:10);
  Readln;
end.


! Works with gfortran but needs the option
!   -assume realloc_lhs
! when compiled with Intel Fortran.

program gauss
  implicit none
  integer, parameter :: p = 16 ! quadruple precision
  integer            :: n = 10, k
  real(kind=p), allocatable :: r(:,:)
  real(kind=p)       :: z, a, b, exact
  do n = 1,20
    a = -3; b = 3
    r = gaussquad(n)
    z = (b-a)/2*dot_product(r(2,:),exp((a+b)/2+r(1,:)*(b-a)/2))
    exact = exp(3.0_p)-exp(-3.0_p)
    print "(i0,1x,g0,1x,g10.2)",n, z, z-exact
  end do

  contains

  function gaussquad(n) result(r)
  integer                 :: n
  real(kind=p), parameter :: pi = 4*atan(1._p)
  real(kind=p)            :: r(2, n), x, f, df, dx
  integer                 :: i,  iter
  real(kind = p), allocatable :: p0(:), p1(:), tmp(:)

  p0 = [1._p]
  p1 = [1._p, 0._p]

  do k = 2, n
     tmp = ((2*k-1)*[p1,0._p]-(k-1)*[0._p, 0._p,p0])/k
     p0 = p1; p1 = tmp
  end do
  do i = 1, n
    x = cos(pi*(i-0.25_p)/(n+0.5_p))
    do iter = 1, 10
      f = p1(1); df = 0._p
      do k = 2, size(p1)
        df = f + x*df
        f  = p1(k) + x * f
      end do
      dx =  f / df
      x = x - dx
      if (abs(dx)<10*epsilon(dx)) exit
    end do
    r(1,i) = x
    r(2,i) = 2/((1-x**2)*df**2)
  end do
  end function
end program


package main

import (
    "fmt"
    "math"
)

// cFunc for continuous function.  A type definition for convenience.
type cFunc func(float64) float64

func main() {
    fmt.Println("integral:", glq(math.Exp, -3, 3, 5))
}

// glq integrates f from a to b by Guass-Legendre quadrature using n nodes.
// For the task, it also shows the intermediate values determining the nodes:
// the n roots of the order n Legendre polynomal and the corresponding n
// weights used for the integration.
func glq(f cFunc, a, b float64, n int) float64 {
    x, w := glqNodes(n, f)
    show := func(label string, vs []float64) {
        fmt.Printf("%8s: ", label)
        for _, v := range vs {
            fmt.Printf("%8.5f ", v)
        }
        fmt.Println()
    }
    show("nodes", x)
    show("weights", w)
    var sum float64
    bma2 := (b - a) * .5
    bpa2 := (b + a) * .5
    for i, xi := range x {
        sum += w[i] * f(bma2*xi+bpa2)
    }
    return bma2 * sum
}

// glqNodes computes both nodes and weights for a Gauss-Legendre
// Quadrature integration.  Parameters are n, the number of nodes
// to compute and f, a continuous function to integrate.  Return
// values have len n.
func glqNodes(n int, f cFunc) (node []float64, weight []float64) {
    p := legendrePoly(n)
    pn := p[n]
    n64 := float64(n)
    dn := func(x float64) float64 {
        return (x*pn(x) - p[n-1](x)) * n64 / (x*x - 1)
    }
    node = make([]float64, n)
    for i := range node {
        x0 := math.Cos(math.Pi * (float64(i+1) - .25) / (n64 + .5))
        node[i] = newtonRaphson(pn, dn, x0)
    }
    weight = make([]float64, n)
    for i, x := range node {
        dnx := dn(x)
        weight[i] = 2 / ((1 - x*x) * dnx * dnx)
    }
    return
}

// legendrePoly constructs functions that implement Lengendre polynomials.
// This is done by function composition by recurrence relation (Bonnet's.)
// For given n, n+1 functions are returned, computing P0 through Pn.
func legendrePoly(n int) []cFunc {
    r := make([]cFunc, n+1)
    r[0] = func(float64) float64 { return 1 }
    r[1] = func(x float64) float64 { return x }
    for i := 2; i <= n; i++ {
        i2m1 := float64(i*2 - 1)
        im1 := float64(i - 1)
        rm1 := r[i-1]
        rm2 := r[i-2]
        invi := 1 / float64(i)
        r[i] = func(x float64) float64 {
            return (i2m1*x*rm1(x) - im1*rm2(x)) * invi
        }
    }
    return r
}

// newtonRaphson is general purpose, although totally primitive, simply
// panicking after a fixed number of iterations without convergence to
// a fixed error.  Parameter f must be a continuous function,
// df its derivative, x0 an initial guess.
func newtonRaphson(f, df cFunc, x0 float64) float64 {
    for i := 0; i < 30; i++ {
        x1 := x0 - f(x0)/df(x0)
        if math.Abs(x1-x0) <= math.Abs(x0*1e-15) {
            return x1
        }
        x0 = x1
    }
    panic("no convergence")
}


gaussLegendre n f a b = d*sum [ w x*f(m + d*x) | x <- roots ]
  where d = (b - a)/2
        m = (b + a)/2
        w x = 2/(1-x^2)/(legendreP' n x)^2
        roots = map (findRoot (legendreP n) (legendreP' n) . x0) [1..n]
        x0 i = cos (pi*(i-1/4)/(n+1/2))


NB. returns coefficents for yth-order Legendre polynomial
getLegendreCoeffs=: verb define M.
  if. y<:1 do. 1 {.~ - y+1 return. end.
  (%~ <:@(,~ +:) -/@:* (0;'') ,&> [: getLegendreCoeffs&.> -&1 2) y
)

getPolyRoots=: 1 {:: p.                                NB. returns the roots of a polynomial
getGaussLegendreWeights=: 2 % [email protected]*:@[ * (*:@p.~ p..)   NB. form: roots getGaussLegendreWeights coeffs
getGaussLegendrePoints=: (getPolyRoots ([ ,: getGaussLegendreWeights) ])@getLegendreCoeffs

NB.*integrateGaussLegendre a Integrates a function u with a n-point Gauss-Legendre quadrature rule over the interval [a,b]
NB. form: npoints function integrateGaussLegendre (a,b)
integrateGaussLegendre=: adverb define
:
  'nodes wgts'=. getGaussLegendrePoints x
  -: (-~/ y) * wgts +/@:* u -: nodes p.~ (+/ , -~/) y
)


import static java.lang.Math.*;
import java.util.function.Function;

public class Test {
    final static int N = 5;

    static double[] lroots = new double[N];
    static double[] weight = new double[N];
    static double[][] lcoef = new double[N + 1][N + 1];

    static void legeCoef() {
        lcoef[0][0] = lcoef[1][1] = 1;

        for (int n = 2; n <= N; n++) {

            lcoef[n][0] = -(n - 1) * lcoef[n - 2][0] / n;

            for (int i = 1; i <= n; i++) {
                lcoef[n][i] = ((2 * n - 1) * lcoef[n - 1][i - 1]
                        - (n - 1) * lcoef[n - 2][i]) / n;
            }
        }
    }

    static double legeEval(int n, double x) {
        double s = lcoef[n][n];
        for (int i = n; i > 0; i--)
            s = s * x + lcoef[n][i - 1];
        return s;
    }

    static double legeDiff(int n, double x) {
        return n * (x * legeEval(n, x) - legeEval(n - 1, x)) / (x * x - 1);
    }

    static void legeRoots() {
        double x, x1;
        for (int i = 1; i <= N; i++) {
            x = cos(PI * (i - 0.25) / (N + 0.5));
            do {
                x1 = x;
                x -= legeEval(N, x) / legeDiff(N, x);
            } while (x != x1);

            lroots[i - 1] = x;

            x1 = legeDiff(N, x);
            weight[i - 1] = 2 / ((1 - x * x) * x1 * x1);
        }
    }

    static double legeInte(Function<Double, Double> f, double a, double b) {
        double c1 = (b - a) / 2, c2 = (b + a) / 2, sum = 0;
        for (int i = 0; i < N; i++)
            sum += weight[i] * f.apply(c1 * lroots[i] + c2);
        return c1 * sum;
    }

    public static void main(String[] args) {
        legeCoef();
        legeRoots();

        System.out.print("Roots: ");
        for (int i = 0; i < N; i++)
            System.out.printf(" %f", lroots[i]);

        System.out.print("\nWeight:");
        for (int i = 0; i < N; i++)
            System.out.printf(" %f", weight[i]);

        System.out.printf("%nintegrating Exp(x) over [-3, 3]:%n\t%10.8f,%n"
                + "compared to actual%n\t%10.8f%n",
                legeInte(x -> exp(x), -3, 3), exp(3) - exp(-3));
    }
}


const factorial = n => n  <= 1 ? 1 : n * factorial(n - 1);
const M = n => (n - (n % 2 !== 0)) / 2;
const gaussLegendre = (fn, a, b, n) => {
	// coefficients of the Legendre polynomial
	const coef = [...Array(M(n) + 1)].map((v, m) => v = (-1) ** m * factorial(2 * n - 2 * m) / (2 ** n * factorial(m) * factorial(n - m) * factorial(n - 2 * m)));
	// the polynomial function
	const f = x => coef.map((v, i) => v * x ** (n - 2 * i)).reduce((sum, item) => sum + item, 0);
	const terms = coef.length - (n % 2 === 0);
	// coefficients of the derivative polybomial
	const dcoef = [...Array(terms)].map((v, i) => v = n - 2 * i).map((val, i) => val * coef[i]);
	// the derivative polynomial function
	const df = x => dcoef.map((v, i) => v * x ** (n - 1 - 2 * i)).reduce((sum, item) => sum + item, 0);
	const guess = [...Array(n)].map((v, i) => Math.cos(Math.PI * (i + 1 - 1 / 4) / (n + 1 / 2)));
	// Newton Raphson
	const roots = guess.map(xo => [...Array(100)].reduce(x => x - f(x) / df(x), xo));
	const weights = roots.map(v => 2 / ((1 - v ** 2) * df(v) ** 2));
	return (b - a) / 2 * weights.map((v, i) => v * fn((b - a) * roots[i] / 2 + (a + b) / 2)).reduce((sum, item) => sum + item, 0);
}
console.log(gaussLegendre(x => Math.exp(x), -3, 3, 5));


using LinearAlgebra

function gauss(a, b, N)
    λ, Q = eigen(SymTridiagonal(zeros(N), [n / sqrt(4n^2 - 1) for n = 1:N-1]))
    @. (λ + 1) * (b - a) / 2 + a, [2Q[1, i]^2 for i = 1:N] * (b - a) / 2
end


import java.lang.Math.*

class Legendre(val N: Int) {
    fun evaluate(n: Int, x: Double) = (n downTo 1).fold(c[n][n]) { s, i -> s * x + c[n][i - 1] }

    fun diff(n: Int, x: Double) = n * (x * evaluate(n, x) - evaluate(n - 1, x)) / (x * x - 1)

    fun integrate(f: (Double) -> Double, a: Double, b: Double): Double {
        val c1 = (b - a) / 2
        val c2 = (b + a) / 2
        return c1 * (0 until N).fold(0.0) { s, i -> s + weights[i] * f(c1 * roots[i] + c2) }
    }

    private val roots = DoubleArray(N)
    private val weights = DoubleArray(N)
    private val c = Array(N + 1) { DoubleArray(N + 1) }    // coefficients

    init {
        // coefficients:
        c[0][0] = 1.0
        c[1][1] = 1.0
        for (n in 2..N) {
            c[n][0] = (1 - n) * c[n - 2][0] / n
            for (i in 1..n)
                c[n][i] = ((2 * n - 1) * c[n - 1][i - 1] - (n - 1) * c[n - 2][i]) / n
        }

        // roots:
        var x: Double
        var x1: Double
        for (i in 1..N) {
            x = cos(PI * (i - 0.25) / (N + 0.5))
            do {
                x1 = x
                x -= evaluate(N, x) / diff(N, x)
            } while (x != x1)

            x1 = diff(N, x)
            roots[i - 1] = x
            weights[i - 1] = 2 / ((1 - x * x) * x1 * x1)
        }

        print("Roots:")
        roots.forEach { print(" %f".format(it)) }
        println()
        print("Weights:")
        weights.forEach { print(" %f".format(it)) }
        println()
    }
}

fun main(args: Array<String>) {
    val legendre = Legendre(5)
    println("integrating Exp(x) over [-3, 3]:")
    println("\t%10.8f".format(legendre.integrate(Math::exp, -3.0, 3.0)))
    println("compared to actual:")
    println("\t%10.8f".format(exp(3.0) - exp(-3.0)))
}


local order = 0

local legendreRoots = {}
local legendreWeights = {}

local function legendre(term, z)
    if (term == 0) then
        return 1
    elseif (term == 1) then
        return z
    else
        return ((2 * term - 1) * z * legendre(term - 1, z) - (term - 1) * legendre(term - 2, z)) / term
    end
end

local function legendreDerivative(term, z)
    if (term == 0) then
        return 0
    elseif (term == 1) then
        return 1
    else
        return ( term * ((z * legendre(term, z)) - legendre(term - 1, z))) / (z * z - 1)
    end
end

local function getLegendreRoots()
    local y, y1

    for index = 1, order do
        y = math.cos(math.pi * (index - 0.25) / (order + 0.5))

        repeat
            y1 = y
            y = y - (legendre(order, y) / legendreDerivative(order, y))
        until y == y1

        table.insert(legendreRoots, y)
    end
end

local function getLegendreWeights()
    for index = 1, order do
        local weight = 2 / ((1 - (legendreRoots[index]) ^ 2) * (legendreDerivative(order, legendreRoots[index])) ^ 2)
        table.insert(legendreWeights, weight)
    end
end

function gaussLegendreQuadrature(f, lowerLimit, upperLimit, n)
    order = n

    do
        getLegendreRoots()
        getLegendreWeights()
    end

    local c1 = (upperLimit - lowerLimit) / 2
    local c2 = (upperLimit + lowerLimit) / 2
    local sum = 0

    for i = 1, order do
        sum = sum + legendreWeights[i] * f(c1 * legendreRoots[i] + c2)
    end

    return c1 * sum
end

do
    print(gaussLegendreQuadrature(function(x) return math.exp(x) end, -3, 3, 5))
end


gaussLegendreQuadrature[func_, {a_, b_}, degree_: 5] :=
Block[{nodes, x, weights},
 nodes = Cases[NSolve[LegendreP[degree, x] == 0, x], _?NumericQ, Infinity];
 weights = 2 (1 - nodes^2)/(degree LegendreP[degree - 1, nodes])^2;
 (b - a)/2 weights.func[(b - a)/2 nodes + (b + a)/2]]
gaussLegendreQuadrature[Exp, {-3, 3}]


%Print the result.
disp(GLGD_int(@(x) exp(x), -3, 3, 5));

%Integration using Gauss-Legendre quad
%Does almost the same as 'integral' in MATLAB
function y=GLGD_int(fun,xmin,xmax,n)
%fun: the intergrand as a function handle
%xmin: lower boundary of integration
%xmax: upper boundary of integration
%n: order of polynomials used (number of integration ponts)
[x_IP,weight]=GLGD_para(n);
%assign global coordinates to the integraton points
x_eval=x_IP*(xmax-xmin)/2+(xmax+xmin)/2;
y=0;
for aa=1:n
    y=y+feval(fun,x_eval(aa))*weight(aa)*(xmax-xmin)/2;
end
end

function [x_IP,weight]=GLGD_para(n)
%n: the order of the polynomial
x_IP=legendreRoot(n,10^(-16));
weight=2./(1-x_IP.^2)./diff_legendrePoly(x_IP,n).^2;
end

%roots of the Legendre Polynomial using Newton-Raphson
function x_IP=legendreRoot(n,tol)
%n: order of the polynomial
%tol: tolerence of the error
if n<2
    disp('No root can be found');
else
    root=zeros(1,floor(n/2));
    for aa=1:floor(n/2) %iterate to find half of the roots
        x=cos(pi*(aa-0.25)/(n+0.5));
        err=10*tol;
        iter=0;
        while (err>tol)&&(iter<1000)
            dx=-legendrePoly(x,n)/diff_legendrePoly(x,n);
            x=x+dx;
            iter=iter+1;
            err=abs(legendrePoly(x,n));
        end
        root(aa)=x;
    end
    if mod(n,2)==0
        x_IP=[-1*root,root];
    else
        x_IP=[-1*root,0,root];
    end
    x_IP=sort(x_IP);
end
end

%derivative of the Legendre Polynomial
function y=diff_legendrePoly(x_IP,n)
%n: order of the polynomial
%x_IP: coordinates of the integration points
if n==0
    y=0;
else
    y=n./(x_IP.^2-1).*(x_IP.*legendrePoly(x_IP,n)-legendrePoly(x_IP,n-1));
end
end

%Produces Legendre Polynomials
function y=legendrePoly(x,n)
%n: order of polynomial
%x: input x
if n==0
    y=1;
elseif n==1
    y=x;
else
    y=((2*n-1).*x.*legendrePoly(x,n-1)-(n-1)*legendrePoly(x,n-2))/n;
end
end


V animals = [
        (‘fly’, ‘I don't know why she swallowed a fly, perhaps she'll die.’),
        (‘spider’, ‘It wiggled and jiggled and tickled inside her.’),
        (‘bird’, ‘How absurd, to swallow a bird.’),
        (‘cat’, ‘Imagine that, she swallowed a cat.’),
        (‘dog’, ‘What a hog, to swallow a dog.’),
        (‘goat’, ‘She just opened her throat and swallowed a goat.’),
        (‘cow’, ‘I don't know how she swallowed a cow.’),
        (‘horse’, ‘She's dead, of course.’)]

L(animal_lyric) animals
   V i = L.index
   V (animal, lyric) = animal_lyric
   print("There was an old lady who swallowed a #..\n#.".format(animal, lyric))

   I animal == ‘horse’
      L.break

   L(predator, prey) zip(animals[(i .< 0).step(-1)], animals[(i - 1 ..).step(-1)])
      print("\tShe swallowed the #. to catch the #.".format(predator[0], prey[0]))

   I animal != ‘fly’
      print(animals[0][1])
   print()


import math, strformat

proc legendreIn(x: float, n: int): float =

  template prev1(idx: int; pn1: float): float =
    (2*idx - 1).float * x * pn1

  template prev2(idx: int; pn2: float): float =
    (idx-1).float * pn2

  if n == 0:
    return 1.0
  elif n == 1:
    return x
  else:
    var
      p1 = float x
      p2 = 1.0
    for i in 2 .. n:
      result = (i.prev1(p1) - i.prev2(p2)) / i.float
      p2 = p1
      p1 = result

proc deriveLegendreIn(x: float, n: int): float =
  template calcresult(curr, prev: float): untyped =
    n.float / (x^2 - 1) * (x * curr - prev)
  result = calcresult(x.legendreIn n, x.legendreIn(n-1))

func guess(n, i: int): float =
  cos(PI * (i.float - 0.25) / (n.float + 0.5))

proc nodes(n: int): seq[(float, float)] =
  result = newseq[(float, float)](n)
  template calc(x: float): untyped =
    x.legendreIn(n) / x.deriveLegendreIn(n)

  for i in 0 .. result.high:
    var x = guess(n, i+1)
    block newton:
      var x0 = x
      x -= calc x
      while abs(x-x0) > 1e-12:
        x0 = x
        x -= calc x

    result[i][0] = x
    result[i][1] = 2 / ((1.0 - x^2) * (x.deriveLegendreIn n)^2)

proc integ(f: proc(x: float): float; ns, p1, p2: int): float =
  template dist: untyped =
    (p2 - p1).float / 2.0
  template avg: untyped =
    (p1 + p2).float / 2.0
  result = dist()
  var
    sum = 0'f
    thenodes = newseq[float](ns)
    weights = newseq[float](ns)
  for i, nw in ns.nodes:
    sum += nw[1] * f(dist() * nw[0] + avg())
    thenodes[i] = nw[0]
    weights[i] = nw[1]

  let apos = ":"
  stdout.write fmt"""{"nodes":>8}{apos}"""
  for n in thenodes:
    stdout.write &" {n:>6.5f}"
  stdout.write "\n"
  stdout.write &"""{"weights":>8}{apos}"""
  for w in weights:
    stdout.write &" {w:>6.5f}"
  stdout.write "\n"
  result *= sum

proc main =
  echo "integral: ", integ(exp, 5, -3, 3)

main()


let rec leg n x = match n with (* Evaluate Legendre polynomial *)
   | 0 -> 1.0
   | 1 -> x
   | k -> let u = 1.0 -. 1.0 /. float k in
      (1.0+.u)*.x*.(leg (k-1) x) -. u*.(leg (k-2) x);;

let leg' n x = match n with (* derivative *)
   | 0 -> 0.0
   | 1 -> 1.0
   | _ -> ((leg (n-1) x) -. x*.(leg n x)) *. (float n)/.(1.0-.x*.x);;

let approx_root k n = (* Reversed Francesco Tricomi: 1 <= k <= n *)
   let pi = acos (-1.0) and s = float(2*n)
   and t = 1.0 +. float(1-4*k)/.float(4*n+2) in
   (1.0 -. (float (n-1))/.(s*.s*.s))*.cos(pi*.t);;

let rec refine r n = (* Newton-Raphson *)
   let r1 = r -. (leg n r)/.(leg' n r) in
   if abs_float (r-.r1) < 2e-16 then r1 else refine r1 n;;

let root k n = refine (approx_root k n) n;;

let node k n = (* Abscissa and weight *)
   let r = root k n in
   let deriv = leg' n r in
   let w = 2.0/.((1.0-.r*.r)*.(deriv*.deriv)) in
   (r,w);;

let nodes n =
   let rec aux k = if k > n then [] else node k n :: aux (k+1)
   in aux 1;;

let quadrature n f a b =
   let f1 x = f ((x*.(b-.a) +. a +. b)*.0.5) in
   let eval s (x,w) = s +. w*.(f1 x) in
   0.5*.(b-.a)*.(List.fold_left eval 0.0 (nodes n));;


	org	100h
	mvi	c,-1	; C = verse counter
verse:	inr 	c
	lxi	d,lady	; There was an old lady who swallowed a ...
	call	prstr
	mov	e,c	; <animal>
	call	pbeast
	lxi	d,comma
	call	prstr
	mov	e,c	; verse
	call	pverse
	mov	a,c	; is this the first verse?
	ana	a
	jz	verse	; then we're not swallowing animals yet
	cpi	7	; otherwise, is the lady dead yet?
	rz		; if so, stop.
	mov	b,c	; otherwise, start swallowing
swallo:	lxi	d,swlw1	; She swallowed the
	call	prstr
	mov	e,b	; <current animal>
	call	pbeast
	lxi	d,swlw2	; to catch the
	call	prstr
	dcr	b
	push	psw	; store state (is B zero now)
	mov	e,b	; <previous animal>
	call	pbeast
	lxi	d,comma
	call 	prstr
	mov	a,b
	cpi	2
	mov	e,b	; print associated verse if < 2
	cc	pverse
	pop	psw	; was B zero?
	jnz	swallo	; if not, swallow more
	jmp	verse	; if so, next verse
prstr:	push	b	; print string in DE
	mvi	c,9
	call 	5
	pop 	b
	ret
pverse:	lxi	h,verses
	jmp	pstrn
pbeast:	lxi	h,beasts
	;;;	Print the E'th string from the list at HL
pstrn:	push	b	; keep counters in B and C
	mvi	a,'$'	; end-of-string marker
	inr	e
pscan:	cmp	m	; keep going until we find one
	inx	h
	jnz	pscan
	dcr	e	; is this the one we wanted?
	jnz	pscan	; if not, keep going
	xchg		; otherwise, put in DE
	mvi	c,9	; print string using CP/M
	call	5
	pop	b	; restore counters
	ret
lady:	db	'There was an old lady who swallowed a '
beasts:	db	'$fly$spider$bird$cat$dog$goat$cow$horse'
verses:	db	'$I don',39,'t know why she swallowed that fly -'
	db	' Perhaps she',39,'ll die.',13,10,13,10
	db	'$That wiggled and jiggled and tickled inside her!',13,10
	db	'$How absurd to swallow a bird',13,10
	db	'$Imagine that! She swallowed a cat!',13,10
	db	'$What a hog to swallow a dog',13,10
	db	'$She just opened her throat and swallowed that goat',13,10
	db	'$I don',39,'t know how she swallowed that cow',13,10
	db	'$She',39,'s dead, of course.',13,10,'$'
swlw1:	db	'She swallowed the $'
swlw2:	db	' to catch the $'
comma:	db	',',13,10,'$'


	cpu	8086
	org	100h
section	.text
	mov	bl,-1		; BL = verse counter
verse:	inc	bl
	mov	dx,lady		; There was an old lady who swallowed
	call	prstr
	mov	dl,bl		; <animal>
	call	pbeast
	mov	dx,comma
	call	prstr
	mov	dl,bl		; verse
	call	pverse
	test	bl,bl		; is this the first verse?
	jz	verse		; then we're not swallowing anything yet
	cmp	bl,7		; otherwise, is the lady dead yet?
	je	stop		; if so, stop.
	mov	bh,bl		; otherwise, start swallowing
swallo:	mov	dx,swlw1	; She swallowed the
	call	prstr
	mov	dl,bh		; <current animal>
	call	pbeast
	mov	dx,swlw2	; to catch the
	call	prstr
	dec	bh		; <previous animal>
	mov	dl,bh
	call 	pbeast
	mov	dx,comma
	call	prstr
	cmp	bh,2		; print associated verse if BH<2
	jae	.next
	mov	dl,bh
	call	pverse
.next:	test	bh,bh		; is BH zero yet?
	jnz	swallo		; if not, swallow next animal
	jmp	verse		; otherwise, print next verse
pverse:	mov	di,verses	; Print verse DL
	jmp	pstrn
pbeast:	mov	di,beasts	; Print animal DL
	;;;	Print DL'th string from [DI]
pstrn:	inc	dl
	mov	al,'$'		; end-of-string marker
.scan:	mov	cx,-1
	repne	scasb
	dec	dl
	jnz	.scan
	mov	dx,di
prstr:	mov	ah,9		; MS-DOS syscall to print a string
	int	21h
stop:	ret
section	.data
lady:	db	'There was an old lady who swallowed a '
beasts:	db	'$fly$spider$bird$cat$dog$goat$cow$horse'
verses:	db	'$I don',39,'t know why she swallowed that fly -'
	db	' Perhaps she',39,'ll die.',13,10,13,10
	db	'$That wiggled and jiggled and tickled inside her!',13,10
	db	'$How absurd to swallow a bird',13,10
	db	'$Imagine that! She swallowed a cat!',13,10
	db	'$What a hog to swallow a dog',13,10
	db	'$She just opened her throat and swallowed that goat',13,10
	db	'$I don',39,'t know how she swallowed that cow',13,10
	db	'$She',39,'s dead, of course.',13,10,'$'
swlw1:	db	'She swallowed the $'
swlw2:	db	' to catch the $'
comma:	db	',',13,10,'$'