Algorithms |
|
Puzzles |
|
A program that writes itself
$ include "seed7_05.s7i"; const array string: prog is []( "$ include \"seed7_05.s7i\";", "const array string: prog is [](", "const proc: main is func", " local var integer: number is 0;", " begin", " for number range 1 to 2 do writeln(prog[number]); end for;", " for number range 1 to 11 do", " writeln(literal(prog[number]) <& \",\");", " end for;", " writeln(literal(prog[12]) <& \");\");", " for number range 3 to 12 do writeln(prog[number]); end for;", " end func;"); const proc: main is func local var integer: number is 0; begin for number range 1 to 2 do writeln(prog[number]); end for; for number range 1 to 11 do writeln(literal(prog[number]) <& ","); end for; writeln(literal(prog[12]) <& ");"); for number range 3 to 12 do writeln(prog[number]); end for; end func;
Brainfuck interpreter
$ include "seed7_05.s7i"; include "osfiles.s7i"; include "getf.s7i"; const proc: brainF (in string: source, inout file: input, inout file: output) is func local var array char: memory is 100000 times '\0;'; var integer: dataPointer is 50000; var integer: instructionPointer is 1; var integer: nestingLevel is 0; begin while instructionPointer <= length(source) do case source[instructionPointer] of when {'>'}: incr(dataPointer); when {'<'}: decr(dataPointer); when {'+'}: incr(memory[dataPointer]); when {'-'}: decr(memory[dataPointer]); when {'.'}: write(output, memory[dataPointer]); when {','}: memory[dataPointer] := getc(input); when {'['}: # Forward if zero at dataPointer if memory[dataPointer] = '\0;' then nestingLevel := 1; repeat incr(instructionPointer); case source[instructionPointer] of when {'['}: incr(nestingLevel); when {']'}: decr(nestingLevel); end case; until nestingLevel = 0; end if; when {']'}: # Backward if non-zero at dataPointer if memory[dataPointer] <> '\0;' then nestingLevel := 1; repeat decr(instructionPointer); case source[instructionPointer] of when {'['}: decr(nestingLevel); when {']'}: incr(nestingLevel); end case; until nestingLevel = 0; end if; end case; incr(instructionPointer); end while; end func; const proc: main is func local var string: source is ""; begin if length(argv(PROGRAM)) <> 1 then writeln("usage: brainf7 source"); else source := convDosPath(argv(PROGRAM)[1]); if fileType(source) <> FILE_REGULAR then writeln(" *** File " <& literal(source) <& " not found"); else brainF(getf(source), IN, OUT); end if; end if; end func;
Function to solve the Towers of Hanoi problem
const proc: hanoi (in integer: disk, in string: source, in string: dest, in string: via) is func begin if disk > 0 then hanoi(pred(disk), source, via, dest); writeln("Move disk " <& disk <& " from " <& source <& " to " <& dest); hanoi(pred(disk), via, dest, source); end if; end func;
Write reciprocal values of the natural numbers from 1 to 20 with 60 digits
$ include "seed7_05.s7i"; include "bigint.s7i"; include "bigrat.s7i"; const proc: main is func local var bigInteger: number is 0_; begin for number range 1_ to 20_ do writeln(1_/number digits 60); end for; end func;
Write the numbers between 1 and 3999 as roman numerals
$ include "seed7_05.s7i"; include "stdio.s7i"; include "wrinum.s7i"; const proc: main is func local var integer: number is 0; begin for number range 1 to 3999 do writeln(str(ROMAN, number)); end for; end func;
Decode roman numerals
const func integer: ROMAN parse (in string: roman) is func result var integer: arabic is 0; local var integer: index is 0; var integer: number is 0; var integer: lastval is 0; begin for index range length(roman) downto 1 do case roman[index] of when {'M', 'm'}: number := 1000; when {'D', 'd'}: number := 500; when {'C', 'c'}: number := 100; when {'L', 'l'}: number := 50; when {'X', 'x'}: number := 10; when {'V', 'v'}: number := 5; when {'I', 'i'}: number := 1; otherwise: raise RANGE_ERROR; end case; if number < lastval then arabic -:= number; else arabic +:= number; end if; lastval := number; end for; end func;
|
|