; ModuleID = 'binary.c'
; source_filename = "binary.c"
; target datalayout = "e-m:w-i64:64-f80:128-n8:16:32:64-S128"
; target triple = "x86_64-pc-windows-msvc19.21.27702"

; This is not strictly LLVM, as it uses the C library function "printf".
; LLVM does not provide a way to print values, so the alternative would be
; to just load the string into memory, and that would be boring.

; Additional comments have been inserted, as well as changes made from the output produced by clang such as putting more meaningful labels for the jumps

$"\[email protected][email protected][email protected]" = comdat any

;--- String constant defintions
@"\[email protected][email protected][email protected]" = linkonce_odr unnamed_addr constant [4 x i8] c"%s\0A\00", comdat, align 1

;--- The declaration for the external C printf function.
declare i32 @printf(i8*, ...)

;--- The declaration for the external C log10 function.
declare double @log10(double) #1

;--- The declaration for the external C malloc function.
declare noalias i8* @malloc(i64) #2

;--- The declaration for the external C free function.
declare void @free(i8*) #2

;----------------------------------------------------------
;-- Function that allocates a string with a binary representation of a number
define i8* @bin(i32) #0 {
;-- uint32_t x (local copy)
  %2 = alloca i32, align 4
;-- size_t bits
  %3 = alloca i64, align 8
;-- intermediate value
  %4 = alloca i8*, align 8
;-- size_t i
  %5 = alloca i64, align 8
  store i32 %0, i32* %2, align 4
;-- x == 0, start determinig what value to initially store in bits
  %6 = load i32, i32* %2, align 4
  %7 = icmp eq i32 %6, 0
  br i1 %7, label %just_one, label %calculate_logs

just_one:
  br label %assign_bits

calculate_logs:
;-- log10((double) x)/log10(2) + 1
  %8 = load i32, i32* %2, align 4
  %9 = uitofp i32 %8 to double
;-- log10((double) x)
  %10 = call double @log10(double %9) #3
;-- log10(2)
  %11 = call double @log10(double 2.000000e+00) #3
;-- remainder of calculation
  %12 = fdiv double %10, %11
  %13 = fadd double %12, 1.000000e+00
  br label %assign_bits

assign_bits:
;-- bits = (x == 0) ? 1 : log10((double) x)/log10(2) + 1;
;-- phi basically selects what the value to assign should be based on which basic block came before
  %14 = phi double [ 1.000000e+00, %just_one ], [ %13, %calculate_logs ]
  %15 = fptoui double %14 to i64
  store i64 %15, i64* %3, align 8
;-- char *ret = malloc((bits + 1) * sizeof (char));
  %16 = load i64, i64* %3, align 8
  %17 = add i64 %16, 1
  %18 = mul i64 %17, 1
  %19 = call noalias i8* @malloc(i64 %18)
  store i8* %19, i8** %4, align 8
  store i64 0, i64* %5, align 8
  br label %loop

loop:
;-- i < bits;
  %20 = load i64, i64* %5, align 8
  %21 = load i64, i64* %3, align 8
  %22 = icmp ult i64 %20, %21
  br i1 %22, label %loop_body, label %exit

loop_body:
;-- ret[bits - i - 1] = (x & 1) ? '1' : '0';
  %23 = load i32, i32* %2, align 4
  %24 = and i32 %23, 1
  %25 = icmp ne i32 %24, 0
  %26 = zext i1 %25 to i64
  %27 = select i1 %25, i32 49, i32 48
  %28 = trunc i32 %27 to i8
  %29 = load i8*, i8** %4, align 8
  %30 = load i64, i64* %3, align 8
  %31 = load i64, i64* %5, align 8
  %32 = sub i64 %30, %31
  %33 = sub i64 %32, 1
  %34 = getelementptr inbounds i8, i8* %29, i64 %33
  store i8 %28, i8* %34, align 1
;-- x >>= 1;
  %35 = load i32, i32* %2, align 4
  %36 = lshr i32 %35, 1
  store i32 %36, i32* %2, align 4
  br label %loop_increment

loop_increment:
;-- i++;
  %37 = load i64, i64* %5, align 8
  %38 = add i64 %37, 1
  store i64 %38, i64* %5, align 8
  br label %loop

exit:
;-- ret[bits] = '\0';
  %39 = load i8*, i8** %4, align 8
  %40 = load i64, i64* %3, align 8
  %41 = getelementptr inbounds i8, i8* %39, i64 %40
  store i8 0, i8* %41, align 1
;-- return ret;
  %42 = load i8*, i8** %4, align 8
  ret i8* %42
}

;----------------------------------------------------------
;-- Entry point into the program
define i32 @main() #0 {
;-- 32-bit zero for the return
  %1 = alloca i32, align 4
;-- size_t i, for tracking the loop index
  %2 = alloca i64, align 8
;-- char* for the result of the bin call
  %3 = alloca i8*, align 8
;-- initialize
  store i32 0, i32* %1, align 4
  store i64 0, i64* %2, align 8
  br label %loop

loop:
;-- while (i < 20)
  %4 = load i64, i64* %2, align 8
  %5 = icmp ult i64 %4, 20
  br i1 %5, label %loop_body, label %exit

loop_body:
;-- char *binstr = bin(i);
  %6 = load i64, i64* %2, align 8
  %7 = trunc i64 %6 to i32
  %8 = call i8* @bin(i32 %7)
  store i8* %8, i8** %3, align 8
;-- printf("%s\n", binstr);
  %9 = load i8*, i8** %3, align 8
  %10 = call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([4 x i8], [4 x i8]* @"\[email protected][email protected][email protected]", i32 0, i32 0), i8* %9)
;-- free(binstr);
  %11 = load i8*, i8** %3, align 8
  call void @free(i8* %11)
  br label %loop_increment

loop_increment:
;-- i++
  %12 = load i64, i64* %2, align 8
  %13 = add i64 %12, 1
  store i64 %13, i64* %2, align 8
  br label %loop

exit:
;-- return 0 (implicit)
  %14 = load i32, i32* %1, align 4
  ret i32 %14
}

attributes #0 = { noinline nounwind optnone uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }
attributes #1 = { nounwind "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }
attributes #2 = { "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }
attributes #3 = { nounwind }

!llvm.module.flags = !{!0, !1}
!llvm.ident = !{!2}

!0 = !{i32 1, !"wchar_size", i32 2}
!1 = !{i32 7, !"PIC Level", i32 2}
!2 = !{!"clang version 6.0.1 (tags/RELEASE_601/final)"}


#lang racket

(define (best-shuffle s)
  (define len (string-length s))
  (define @ string-ref)
  (define r (list->string (shuffle (string->list s))))
  (for* ([i (in-range len)] [j (in-range len)])
    (when (not (or (= i j) (eq? (@ s i) (@ r j)) (eq? (@ s j) (@ r i))))
      (define t (@ r i))
      (string-set! r i (@ r j))
      (string-set! r j t)))
  r)

(define (count-same s1 s2)
  (for/sum ([c1 (in-string s1)] [c2 (in-string s2)])
    (if (eq? c1 c2) 1 0)))

(for ([s (in-list '("abracadabra" "seesaw" "elk" "grrrrrr" "up" "a"))])
  (define sh (best-shuffle s))
  (printf " ~a, ~a, (~a)\n" s sh (count-same s sh)))


sub best-shuffle(Str $orig) {

    my @s = $orig.comb;
    my @t = @s.pick(*);

    for ^@s -> $i {
        for ^@s -> $j {
            if $i != $j and @t[$i] ne @s[$j] and @t[$j] ne @s[$i] {
                @t[$i, $j] = @t[$j, $i];
                last;
            }
        }
    }

    my $count = 0;
    for @t.kv -> $k,$v {
        ++$count if $v eq @s[$k]
    }

    return (@t.join, $count);
}

printf "%s, %s, (%d)\n", $_, best-shuffle $_
    for <abracadabra seesaw elk grrrrrr up a>;


10 PRINT BIN$(5)
20 PRINT BIN$(50)
30 PRINT BIN$(9000)


HAI 1.3
HOW IZ I DECIMULBINUR YR DECIMUL
  I HAS A BINUR ITZ ""
  IM IN YR DUUH
    BOTH SAEM DECIMUL AN SMALLR OF DECIMUL AN 0, O RLY?
      YA RLY, GTFO
    OIC
    BINUR R SMOOSH MOD OF DECIMUL AN 2 BINUR MKAY
    DECIMUL R MAEK QUOSHUNT OF DECIMUL AN 2 A NUMBR
  IM OUTTA YR DUUH
  FOUND YR BINUR
IF U SAY SO
VISIBLE I IZ DECIMULBINUR YR 5 MKAY
VISIBLE I IZ DECIMULBINUR YR 50 MKAY
VISIBLE I IZ DECIMULBINUR YR 9000 MKAY
KTHXBYE


import Prelude;

public tuple[str, str, int] bestShuffle(str s){
     characters = chars(s);

     ranking = {<p, countSame(p, characters)> | p <- permutations(characters)};
     best = {<s, stringChars(p), n> | <p, n> <- ranking, n == min(range(ranking))};
     return takeOneFrom(best)[0];
}

public int countSame(list[int] permutations, list[int] characters){
     return (0 | it + 1 | n <- index(characters), permutations[n] == characters[n]);
}


/*REXX program determines and displays the best shuffle for any list of words or tokens.*/
parse arg $                                      /*get some words from the command line.*/
if $=''  then $= 'tree abracadabra seesaw elk grrrrrr up a'          /*use the defaults?*/
w=0;                #=words($)                   /* [↑]  finds the widest word in $ list*/
        do i=1  for #;  @.i=word($,i);  w=max(w, length(@.i) );   end  /*i*/
w= w+9                                           /*add 9 blanks for output indentation. */
        do n=1  for #;  new= bestShuffle(@.n)    /*process the examples in the @ array. */
        same=0;                    do m=1  for length(@.n)
                                   same=same  +  (substr(@.n, m, 1) == substr(new, m, 1) )
                                   end   /*m*/
        say '       original:'   left(@.n, w)    'new:'    left(new,w)    'score:'    same
        end   /*n*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
bestShuffle: procedure; parse arg x 1 ox;    L=length(x);   if L<3  then return reverse(x)
                                                             /*[↑] fast track short strs*/
               do j=1  for L-1;  parse var x =(j) a +1 b +1  /*get A,B at Jth & J+1 pos.*/
               if a\==b  then iterate                        /*ignore any replicates.   */
               c= verify(x,a);    if c==0  then iterate      /*   "    "      "         */
               x= overlay( substr(x,c,1), overlay(a,x,c), j) /*swap the  x,c  characters*/
               rx= reverse(x)                                /*obtain the reverse of X. */
               y= substr(rx, verify(rx, a), 1)               /*get 2nd replicated char. */
               x= overlay(y, overlay(a,x, lastpos(y,x)),j+1) /*fast swap of 2 characters*/
               end   /*j*/
                          do k=1  for L;  a=substr(x, k, 1)      /*handle a possible rep*/
                          if a\==substr(ox, k, 1)  then iterate  /*skip non-replications*/
                          if k==L  then x= left(x, k-2)a || substr(x, k-1,1) /*last case*/
                                   else x= left(x, k-1)substr(x, k+1, 1)a || substr(x,k+2)
                          end   /*k*/
             return x


function dec2bin (n)
    local bin = ""
    while n > 0 do
        bin = n % 2 .. bin
        n = math.floor(n / 2)
    end
    return bin
end

print(dec2bin(5))
print(dec2bin(50))
print(dec2bin(9000))


Module Checkit {
      Form 90, 40
      Function BinFunc${
            Dim  Base 0, One$(16)
            One$( 0 ) = "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111", "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"
            =lambda$ One$() (x, oct as long=4, bypass as boolean=True) ->{
                  if oct>0 and oct<5 then {
                       oct=2*(int(4-oct) mod 4+1)-1
                  } Else oct=1
                  hx$ = Hex$(x, 4 )
                  Def Ret$
                  If Bypass then {
                        For i= oct to len(hx$)
                              if bypass Then if Mid$(hx$, i, 1 )="0" Else bypass=false
                              If bypass and i<>Len(hx$) Then Continue
                              Ret$ += One$( EVal( "0x" + Mid$(hx$, i, 1 ) ) )
                        Next i
                        oct=instr(Ret$, "1")
                        if oct=0 then {
                               Ret$="0"
                        } Else Ret$=mid$(Ret$, oct)
                  } Else {
                        For i= oct to len(hx$)
                              Ret$ += One$( EVal( "0x" + Mid$(hx$, i, 1 ) ) )
                        Next i
                  }
                  =Ret$
            }
      }
      Bin$=BinFunc$()
      Stack New {
            Data 9, 50, 9000
            While not empty {
                  Read x
                  Print Format$("The decimal value {0::-10} should produce an output of {1:-32}",x, Bin$(x) )
            }
      }
      Stack New {
            Data 9, 50, 9000
            While not empty {
                  Read x
                  Print Format$("The decimal value {0::-10} should produce an output of {1:-32}",x, Bin$(x,,false) )
            }
      }
      Stack New {
            Data 9, 50, 9000
            While not empty {
                  Read x
                  Print Bin$(x)
            }
      }
}
Checkit


            NORMAL MODE IS INTEGER

            INTERNAL FUNCTION(NUM)
            ENTRY TO BINARY.
            BTEMP = NUM
            BRSLT = 0
            BDIGIT = 1
BIT         WHENEVER BTEMP.NE.0
                BRSLT = BRSLT + BDIGIT * (BTEMP-BTEMP/2*2)
                BTEMP = BTEMP/2
                BDIGIT = BDIGIT * 10
                TRANSFER TO BIT
            END OF CONDITIONAL
            FUNCTION RETURN BRSLT
            END OF FUNCTION

            THROUGH SHOW, FOR VALUES OF N = 5, 50, 9000
SHOW        PRINT FORMAT FMT, N, BINARY.(N)

            VECTOR VALUES FMT = $I4,2H: ,I16*$
            END OF PROGRAM


# Project : Best shuffle

test = ["abracadabra", "seesaw", "elk", "grrrrrr", "up", "a"]

for n = 1 to len(test)
     bs   = bestshuffle(test[n])
     count = 0
     for p = 1 to len(test[n])
          if substr(test[n],p,1) = substr(bs,p,1)
             count = count + 1
          ok
      next
      see test[n] + " -> " + bs + " " + count + nl
next

func bestshuffle(s1)
       s2 = s1
       for i = 1 to len(s2)
            for j =  1 to len(s2)
                 if (i != j) and (s2[i] != s1[j]) and (s2[j] != s1[i])
                    if j < i
                       i1 = j
                       j1 = i
                    else
                       i1 = i
                       j1 = j
                    ok
                    s2 = left(s2,i1-1) + substr(s2,j1,1) + substr(s2,i1+1,(j1-i1)-1) + substr(s2,i1,1) + substr(s2,j1+1)
                 ok
            next
       next
       bestshuffle = s2
       return bestshuffle


def best_shuffle(s)
  # Fill _pos_ with positions in the order
  # that we want to fill them.
  pos = []
  # g["a"] = [2, 4] implies that s[2] == s[4] == "a"
  g = s.length.times.group_by { |i| s[i] }

  # k sorts letters from low to high count
  k = g.sort_by { |k, v| v.length }.map { |k, v| k }

  until g.empty?
    k.each do |letter|
      g[letter] or next
      pos.push(g[letter].pop)
      g[letter].empty? and g.delete letter
    end
  end

  # Now fill in _new_ with _letters_ according to each position
  # in _pos_, but skip ahead in _letters_ if we can avoid
  # matching characters that way.
  letters = s.dup
  new = "?" * s.length
  until letters.empty?
    i, p = 0, pos.pop
    i += 1 while letters[i] == s[p] and i < (letters.length - 1)
    new[p] = letters.slice! i
  end

  score = new.chars.zip(s.chars).count { |c, d| c == d }
  [new, score]
end

%w(abracadabra seesaw elk grrrrrr up a).each do |word|
  puts "%s, %s, (%d)" % [word, *best_shuffle(word)]
end


StringJoin @@ ToString /@ IntegerDigits[50, 2]


  dec2bin(5)
  dec2bin(50)
  dec2bin(9000)


list$ = "abracadabra seesaw pop grrrrrr up a"

while word$(list$,ii + 1," ") <> ""
 ii    = ii + 1
 w$    = word$(list$,ii," ")
 bs$   = bestShuffle$(w$)
 count = 0
 for i = 1 to len(w$)
  if mid$(w$,i,1) = mid$(bs$,i,1) then count = count + 1
 next i
 print  w$;" ";bs$;" ";count
wend

function bestShuffle$(s1$)
   s2$   = s1$
   for i = 1 to len(s2$)
        for j =  1 to len(s2$)
            if (i <> j) and (mid$(s2$,i,1) <> mid$(s1$,j,1)) and (mid$(s2$,j,1) <> mid$(s1$,i,1)) then
            if j < i then i1 = j:j1 = i else i1 = i:j1 = j
            s2$ = left$(s2$,i1-1) + mid$(s2$,j1,1) + mid$(s2$,i1+1,(j1-i1)-1) + mid$(s2$,i1,1) + mid$(s2$,j1+1)
            end if
        next j
   next i
bestShuffle$ = s2$
end function


extern crate permutohedron;
extern crate rand;

use std::cmp::{min, Ordering};
use std::env;
use rand::{thread_rng, Rng};
use std::str;

const WORDS: &'static [&'static str] = &["abracadabra", "seesaw", "elk", "grrrrrr", "up", "a"];

#[derive(Eq)]
struct Solution {
    original: String,
    shuffled: String,
    score: usize,
}

// Ordering trait implementations are only needed for the permutations method
impl PartialOrd for Solution {
    fn partial_cmp(&self, other: &Solution) -> Option<Ordering> {
        match (self.score, other.score) {
            (s, o) if s < o => Some(Ordering::Less),
            (s, o) if s > o => Some(Ordering::Greater),
            (s, o) if s == o => Some(Ordering::Equal),
            _ => None,
        }
    }
}

impl PartialEq for Solution {
    fn eq(&self, other: &Solution) -> bool {
        match (self.score, other.score) {
            (s, o) if s == o => true,
            _ => false,
        }
    }
}

impl Ord for Solution {
    fn cmp(&self, other: &Solution) -> Ordering {
        match (self.score, other.score) {
            (s, o) if s < o => Ordering::Less,
            (s, o) if s > o => Ordering::Greater,
            _ => Ordering::Equal,
        }
    }
}

fn _help() {
    println!("Usage: best_shuffle <word1> <word2> ...");
}

fn main() {
    let args: Vec<String> = env::args().collect();
    let mut words: Vec<String> = vec![];

    match args.len() {
        1 => {
            for w in WORDS.iter() {
                words.push(String::from(*w));
            }
        }
        _ => {
            for w in args.split_at(1).1 {
                words.push(w.clone());
            }
        }
    }

    let solutions = words.iter().map(|w| best_shuffle(w)).collect::<Vec<_>>();

    for s in solutions {
        println!("{}, {}, ({})", s.original, s.shuffled, s.score);
    }
}

// Implementation iterating over all permutations
fn _best_shuffle_perm(w: &String) -> Solution {
    let mut soln = Solution {
        original: w.clone(),
        shuffled: w.clone(),
        score: w.len(),
    };
    let w_bytes: Vec<u8> = w.clone().into_bytes();
    let mut permutocopy = w_bytes.clone();
    let mut permutations = permutohedron::Heap::new(&mut permutocopy);
    while let Some(p) = permutations.next_permutation() {
        let hamm = hamming(&w_bytes, p);
        soln = min(soln,
                   Solution {
                       original: w.clone(),
                       shuffled: String::from(str::from_utf8(p).unwrap()),
                       score: hamm,
                   });
        // Accept the solution if score 0 found
        if hamm == 0 {
            break;
        }
    }
    soln
}

// Quadratic implementation
fn best_shuffle(w: &String) -> Solution {
    let w_bytes: Vec<u8> = w.clone().into_bytes();
    let mut shuffled_bytes: Vec<u8> = w.clone().into_bytes();

    // Shuffle once
    let sh: &mut [u8] = shuffled_bytes.as_mut_slice();
    thread_rng().shuffle(sh);

    // Swap wherever it doesn't decrease the score
    for i in 0..sh.len() {
        for j in 0..sh.len() {
            if (i == j) | (sh[i] == w_bytes[j]) | (sh[j] == w_bytes[i]) | (sh[i] == sh[j]) {
                continue;
            }
            sh.swap(i, j);
            break;
        }
    }

    let res = String::from(str::from_utf8(sh).unwrap());
    let res_bytes: Vec<u8> = res.clone().into_bytes();
    Solution {
        original: w.clone(),
        shuffled: res,
        score: hamming(&w_bytes, &res_bytes),
    }
}

fn hamming(w0: &Vec<u8>, w1: &Vec<u8>) -> usize {
    w0.iter().zip(w1.iter()).filter(|z| z.0 == z.1).count()
}


digits([arg]) := block(
   [n: first(arg), b: if length(arg) > 1 then second(arg) else 10, v: [ ], q],
   do (
     [n, q]: divide(n, b),
     v: cons(q, v),
     if n=0 then return(v)))$

binary(n) := simplode(digits(n, 2))$
binary(9000);
/*
                                10001100101000
*/


-- MAXScript: Output decimal numbers from 0 to 16 as Binary : N.H. 2019
for k = 0 to 16 do
(
temp = ""
binString = ""
b = k
-- While loop wont execute for zero so force string to zero
if b == 0 then temp = "0"
	while b > 0 do
	(
	rem = b
	b = b / 2
	   If ((mod rem 2) as Integer) == 0 then temp = temp + "0"
	   else temp = temp + "1"
    )
-- Reverse the binary string
for r = temp.count to 1 by -1 do
(
binString = binString + temp[r]
)
print binString
)


:- module binary_digits.
:- interface.

:- import_module io.
:- pred main(io::di, io::uo) is det.

:- implementation.
:- import_module int, list, string.

main(!IO) :-
    list.foldl(print_binary_digits, [5, 50, 9000], !IO).

:- pred print_binary_digits(int::in, io::di, io::uo) is det.

print_binary_digits(N, !IO) :-
    io.write_string(int_to_base_string(N, 2), !IO),
    io.nl(!IO).


  def coincidients(s1: Seq[Char], s2: Seq[Char]): Int = (s1, s2).zipped.count(p => (p._1 == p._2))
  def freqMap(s1: List[Char]) = s1.groupBy(_.toChar).mapValues(_.size)
  def estimate(s1: List[Char]): Int = if (s1 == Nil) 0 else List(0, freqMap(s1).maxBy(_._2)._2 - (s1.size / 2)).max

  def bestShuffle(s: String): Pair[String, Int] = {
    if (s == "") return ("", 0) else {}
    val charList = s.toList
    val estim = estimate(charList)

    // purely functional polynomial solution
    def doStep(accu: List[Pair[Int, Int]], sourceFreqMap: Map[Int, Int], targetFreqMap: Map[Int, Int], stepsLeft: Int): List[Pair[Int, Int]] = {
      if (stepsLeft == 0) accu else {
        val srcChoices = sourceFreqMap.groupBy(_._2).minBy(_._1)._2
        val src = srcChoices.toList.apply(Random.nextInt(srcChoices.size))._1

        val tgtChoices = targetFreqMap.map(p => if (charList(p._1) != charList(src)) (p._1, p._2) else (p._1, Int.MaxValue / 2)).groupBy(_._2).minBy(_._1)._2
        val tgt = tgtChoices.toList.apply(Random.nextInt(tgtChoices.size))._1
        doStep((src, tgt) :: accu,
          sourceFreqMap.filterKeys(_ != src).map(p => if (charList(p._1) != charList(tgt)) (p._1, p._2 - 1) else (p._1, p._2)),
          targetFreqMap.filterKeys(_ != tgt).map(p => if (charList(p._1) != charList(src)) (p._1, p._2 - 1) else (p._1, p._2)),
          stepsLeft - 1)
      }
    }

    val leftFreqMap: Map[Int, Int] = charList.zipWithIndex.map(p => (p._2, p._1)).toMap.mapValues(x => freqMap(charList).mapValues(charList.size - _)(x))

    val substs = doStep(List(), leftFreqMap, leftFreqMap, charList.size)
    val res = substs.sortBy(_._1).map(p => charList(p._2))
    (res.mkString, coincidients(charList, res))

    // exponential solution (inefficient)
    //Random.shuffle(charList).permutations.find(coincidients(charList, _) <= estim)

  }


(2 over over mod 'div dip) :divmod2

(
  :n () =list
  (n 0 >) (n divmod2 list append #list @n) while
  list reverse 'string map "" join
  "^0+" "" replace   ;remove leading zeroes
) :bin

(5 50 9000) (bin puts) foreach


binary = function(n)
    result = ""
    while n
        result = str(n%2) + result
        n = floor(n/2)
    end while
    if not result then return "0"
    return result
end function

print binary(5)
print binary(50)
print binary(9000)
print binary(0)


fun binary
		(0, b)	=	implode ` map (fn x = if int x then chr (x + 48) else x) b
	|	(n, b)	=	binary (n div 2, n mod 2 :: b)
	|	n	=	binary (n, [])
;


(define count
  (lambda (str1 str2)
    (let ((len (string-length str1)))
      (let loop ((index 0)
                 (result 0))
        (if (= index len)
            result
            (loop (+ index 1)
                  (if (eq? (string-ref str1 index)
                           (string-ref str2 index))
                      (+ result 1)
                      result)))))))

(define swap
  (lambda (str index1 index2)
    (let ((mutable (string-copy str))
          (char1 (string-ref str index1))
          (char2 (string-ref str index2)))
      (string-set! mutable index1 char2)
      (string-set! mutable index2 char1)
      mutable)))

(define shift
  (lambda (str)
    (string-append (substring str 1 (string-length str))
                   (substring str 0 1))))

(define shuffle
  (lambda (str)
    (let* ((mutable (shift str))
           (len (string-length mutable))
           (max-index (- len 1)))
      (let outer ((index1 0)
                  (best mutable)
                  (best-count (count str mutable)))
        (if (or (< max-index index1)
                (= best-count 0))
            best
            (let inner ((index2 (+ index1 1))
                        (best best)
                        (best-count best-count))
              (if (= len index2)
                  (outer (+ index1 1)
                         best
                         best-count)
                  (let* ((next-mutable (swap best index1 index2))
                         (next-count (count str next-mutable)))
                    (if (= 0 next-count)
                        next-mutable
                        (if (< next-count best-count)
                            (inner (+ index2 1)
                                   next-mutable
                                   next-count)
                            (inner (+ index2 1)
                                   best
                                   best-count)))))))))))

(for-each
 (lambda (str)
   (let ((shuffled (shuffle str)))
     (display
      (string-append str " " shuffled " ("
                     (number->string (count str shuffled)) ")\n"))))
 '("abracadabra" "seesaw" "elk" "grrrrrr" "up" "a"))


MODULE Binary;
FROM FormatString IMPORT FormatString;
FROM Terminal IMPORT Write,WriteLn,ReadChar;

PROCEDURE PrintByte(b : INTEGER);
VAR v : INTEGER;
BEGIN
    v := 080H;
    WHILE v#0 DO
        IF (b BAND v) # 0 THEN
            Write('1')
        ELSE
            Write('0')
        END;
        v := v SHR 1
    END
END PrintByte;

VAR
    buf : ARRAY[0..15] OF CHAR;
    i : INTEGER;
BEGIN
    FOR i:=0 TO 15 DO
        PrintByte(i);
        WriteLn
    END;

    ReadChar
END Binary.


MODULE Binary EXPORTS Main;

IMPORT IO, Fmt;

VAR num := 10;

BEGIN
  IO.Put(Fmt.Int(num, 2) & "\n");
  num := 150;
  IO.Put(Fmt.Int(num, 2) & "\n");
END Binary.


$ include "seed7_05.s7i";

const func string: bestShuffle (in string: stri) is func
  result
    var string: shuffled is "";
  local
    var char: tmp is ' ';
    var integer: i is 0;
    var integer: j is 0;
  begin
    shuffled := stri;
    for key i range shuffled do
      for key j range shuffled do
        if i <> j and stri[i] <> shuffled[j] and stri[j] <> shuffled[i] then
          tmp  := shuffled[i];
          shuffled @:= [i] shuffled[j];
          shuffled @:= [j] tmp;
        end if;
      end for;
    end for;
  end func;

const proc: main is func
  local
    const array string: testData is [] ("abracadabra", "seesaw", "elk", "grrrrrr", "up", "a");
    var string: original is "";
    var string: shuffled is "";
    var integer: j is 0;
    var integer: score is 0;
  begin
    for original range testData do
      shuffled := bestShuffle(original);
      score := 0;
      for key j range shuffled do
        if original[j] = shuffled[j] then
          incr(score);
        end if;
      end for;
      writeln(original <& ", " <& shuffled <& ", (" <& score <& ")");
    end for;
  end func;


func best_shuffle(String orig) -> (String, Number) {

    var s = orig.chars
    var t = s.shuffle

    for i (^s) {
        for j (^s) {
            if (i!=j && t[i]!=s[j] && t[j]!=s[i]) {
                t[i, j] = t[j, i]
                break
            }
        }
    }

    (t.join, s ~Z== t -> count(true))
}

for word (<abracadabra seesaw elk grrrrrr up a>) {
    var (sword, score) = best_shuffle(word)
    "%-12s %12s: %d\n".printf(word, sword, score)
}


/* NetRexx */
options replace format comments java crossref symbols nobinary

runSample(arg)
return

method getBinaryDigits(nr) public static
  bd = nr.d2x.x2b.strip('L', 0)
  if bd.length = 0 then bd = 0
  return bd

method runSample(arg) public static
  parse arg list
  if list = '' then list = '0 5 50 9000'
  loop n_ = 1 to list.words
    w_ = list.word(n_)
    say w_.right(20)':' getBinaryDigits(w_)
    end n_


;;;	Using the built-in "bits" function
;;;	For integers up to 9,223,372,036,854,775,807
(map println (map bits '(0 5 50 9000)))
;;;	n > 0, "unlimited" size
(define (big-bits n)
	(let (res "")
		(while (> n 0)
			(push (if (even? n) "0" "1") res)
			(setq n (/ n 2)))
		res))
;;;	Example
(println (big-bits 1234567890123456789012345678901234567890L))


package require Tcl 8.5
package require struct::list

# Simple metric function; assumes non-empty lists
proc count {l1 l2} {
    foreach a $l1 b $l2 {incr total [string equal $a $b]}
    return $total
}
# Find the best shuffling of the string
proc bestshuffle {str} {
    set origin [split $str ""]
    set best $origin
    set score [llength $origin]
    struct::list foreachperm p $origin {
	if {$score > [set score [tcl::mathfunc::min $score [count $origin $p]]]} {
	    set best $p
	}
    }
    set best [join $best ""]
    return "$str,$best,($score)"
}


#import std
#import nat

words = <'abracadabra','seesaw','elk','grrrrrr','up','a'>

shuffle = num; ^H/(*@K24) ^H\~&lS @rK2lSS *+ ^arPfarhPlzPClyPCrtPXPRalPqzyCipSLK24\~&L leql$^NS

#show+

main = ~&LS <.~&l,@r :/` ,' ('--+ --')'+ ~&h+ %nP+ [email protected]>^(~&,shuffle)* words


proc binDigits(x: BiggestInt, r: int): int =
  ## Calculates how many digits `x` has when each digit covers `r` bits.
  result = 1
  var y = x shr r
  while y > 0:
    y = y shr r
    inc(result)

proc toBin*(x: BiggestInt, len: Natural = 0): string =
  ## converts `x` into its binary representation. The resulting string is
  ## always `len` characters long. By default the length is determined
  ## automatically. No leading ``0b`` prefix is generated.
  var
    mask: BiggestInt = 1
    shift: BiggestInt = 0
    len = if len == 0: binDigits(x, 1) else: len
  result = newString(len)
  for j in countdown(len-1, 0):
    result[j] = chr(int((x and mask) shr shift) + ord('0'))
    shift = shift + 1
    mask = mask shl 1

for i in 0..15:
  echo toBin(i)


MODULE BinaryDigits;
IMPORT  Out;

  PROCEDURE OutBin(x: INTEGER);
  BEGIN
    IF x > 1 THEN OutBin(x DIV 2) END;
    Out.Int(x MOD 2, 1);
  END OutBin;

BEGIN
  OutBin(0); Out.Ln;
  OutBin(1); Out.Ln;
  OutBin(2); Out.Ln;
  OutBin(3); Out.Ln;
  OutBin(42); Out.Ln;
END BinaryDigits.


Option Explicit

Sub Main_Best_shuffle()
Dim S() As Long, W, b As Byte, Anagram$, Count&, myB As Boolean, Limit As Byte, i As Integer

    W = Array("a", "abracadabra", "seesaw", "elk", "grrrrrr", "up", "qwerty", "tttt")
    For b = 0 To UBound(W)
        Count = 0
        Select Case Len(W(b))
            Case 1: Limit = 1
            Case Else
                i = NbLettersDiff(W(b))
                If i >= Len(W(b)) \ 2 Then
                    Limit = 0
                ElseIf i = 1 Then
                    Limit = Len(W(b))
                Else
                    Limit = Len(W(b)) - i
                End If
        End Select
RePlay:
        Do
            S() = ShuffleIntegers(Len(W(b)))
            myB = GoodShuffle(S, Limit)
        Loop While Not myB
        Anagram = ShuffleWord(CStr(W(b)), S)
        Count = Nb(W(b), Anagram)
        If Count > Limit Then GoTo RePlay
        Debug.Print W(b) & " ==> " & Anagram & " (Score : " & Count & ")"
    Next
End Sub

Function ShuffleIntegers(l As Long) As Long()
Dim i As Integer, ou As Integer, temp() As Long
Dim C As New Collection

    ReDim temp(l - 1)
    If l = 1 Then
        temp(0) = 0
    ElseIf l = 2 Then
        temp(0) = 1: temp(1) = 0
    Else
        Randomize
        Do
            ou = Int(Rnd * l)
            On Error Resume Next
            C.Add CStr(ou), CStr(ou)
            If Err <> 0 Then
                On Error GoTo 0
            Else
                temp(ou) = i
                i = i + 1
            End If
        Loop While C.Count <> l
    End If
    ShuffleIntegers = temp
End Function

Function GoodShuffle(t() As Long, Lim As Byte) As Boolean
Dim i&, C&

    For i = LBound(t) To UBound(t)
        If t(i) = i Then C = C + 1
    Next i
    GoodShuffle = (C <= Lim)
End Function

Function ShuffleWord(W$, S() As Long) As String
Dim i&, temp, strR$

    temp = Split(StrConv(W, vbUnicode), Chr(0))
    For i = 0 To UBound(S)
        strR = strR & temp(S(i))
    Next i
    ShuffleWord = strR
End Function

Function Nb(W, A) As Integer
Dim i As Integer, l As Integer

    For i = 1 To Len(W)
        If Mid(W, i, 1) = Mid(A, i, 1) Then l = l + 1
    Next i
    Nb = l
End Function

Function NbLettersDiff(W) As Integer
Dim i&, C As New Collection
    For i = 1 To Len(W)
        On Error Resume Next
        C.Add Mid(W, i, 1), Mid(W, i, 1)
    Next i
    NbLettersDiff = C.Count
End Function


class Binary {
  function : Main(args : String[]) ~ Nil {
    5->ToBinaryString()->PrintLine();
    50->ToBinaryString()->PrintLine();
    9000->ToBinaryString()->PrintLine();
  }
}


let bin_of_int d =
  if d < 0 then invalid_arg "bin_of_int" else
  if d = 0 then "0" else
  let rec aux acc d =
    if d = 0 then acc else
    aux (string_of_int (d land 1) :: acc) (d lsr 1)
  in
  String.concat "" (aux [] d)

let () =
  let d = read_int () in
  Printf.printf "%8s\n" (bin_of_int d)


'Best Shuffle Task
'VBScript Implementation

Function bestshuffle(s)
    Dim arr:Redim arr(Len(s)-1)

    'The Following Does the toCharArray() Functionality
    For i = 0 To Len(s)-1
        arr(i) = Mid(s, i + 1, 1)
    Next

    arr = shuffler(arr)     'Make this line a comment for deterministic solution
    For i = 0 To UBound(arr):Do
        If arr(i) <> Mid(s, i + 1, 1) Then Exit Do
        For j = 0 To UBound(arr)
            If arr(i) <> arr(j) And arr(i) <> Mid(s, j + 1, 1) And arr(j) <> Mid(s, i + 1, 1) Then
                tmp = arr(i)
                arr(i) = arr(j)
                arr(j) = tmp
            End If
        Next
    Loop While False:Next

    shuffled_word = Join(arr,"")

    'This section is the scorer
    score = 0
    For k = 1 To Len(s)
        If Mid(s,k,1) = Mid(shuffled_word,k,1) Then
            score = score + 1
        End If
    Next

    bestshuffle = shuffled_word & ",(" & score & ")"
End Function

Function shuffler(array)
    Set rand = CreateObject("System.Random")
    For i = UBound(array) to 0 Step -1
       r = rand.next_2(0, i + 1)
       tmp = array(i)
       array(i) = array(r)
       array(r) = tmp
    Next
    shuffler = array
End Function

'Testing the function
word_list = Array("abracadabra","seesaw","elk","grrrrrr","up","a")
For Each word In word_list
    WScript.StdOut.WriteLine word & "," & bestshuffle(word)
Next


import "random" for Random

class BestShuffle {
    static shuffle_(ca) {
        var rand = Random.new()
        var i = ca.count - 1
        while (i >= 1) {
            var r = rand.int(i + 1)
            var tmp = ca[i]
            ca[i] = ca[r]
            ca[r] = tmp
            i = i - 1
        }
    }

    static count_(ca, s1) {
        var count = 0
        for (i in 0...ca.count) if (s1[i] == ca[i]) count = count + 1
        return count
    }

    static invoke(s1) {
        var s2 = s1.toList
        shuffle_(s2)
        for (i in 0...s2.count) {
            if (s2[i] == s1[i]) {
                for (j in 0...s2.count) {
                    if (s2[i] != s2[j] && s2[i] != s1[j] && s2[j] != s1[i]) {
                        var tmp = s2[i]
                        s2[i] = s2[j]
                        s2[j] = tmp
                        break
                    }
                }
            }
        }
        return s1 + ", " + s2.join() + ", (" + "%(count_(s2, s1))" + ")"
    }
}

var words = ["tree", "abracadabra", "seesaw", "elk", "grrrrrr", "up", "a"]
words.each { |w| System.print(BestShuffle.invoke(w)) }


(print (number->string 5 2))
(print (number->string 50 2))
(print (number->string 9000 2))


function BinaryBits(sys n) as string
  string buf=nuls 32
  sys p=strptr buf
  sys le
  mov eax,n
  mov edi,p
  mov ecx,32
  '
  'STRIP LEADING ZEROS
  (
   dec ecx
   jl fwd done
   shl eax,1
   jnc repeat
  )
  'PLACE DIGITS
  '
  mov byte [edi],49 '1'
  inc edi
  (
   cmp ecx,0
   jle exit
   mov dl,48 '0'
   shl eax,1
   (
    jnc exit
    mov dl,49 '1'
   )
   mov [edi],dl
   inc edi
   dec ecx
   repeat
  )
  done:
  '
  sub edi,p
  mov le,edi
  if le then return left buf,le
  return "0"
end function

print BinaryBits 0xaa 'result 10101010


include c:\cxpl\codes;  \'code' declarations
string 0;               \use zero-terminated string convention

func StrLen(A);         \Return number of characters in an ASCIIZ string
char A;
int  I;
for I:= 0 to -1>>1-1 do
        if A(I) = 0 then return I;

proc Shuffle(W0);       \Display best shuffle of characters in a word
char W0;
char W(20), SW(20);
int  L, I, S, SS, C, T;
[L:= StrLen(W0);                        \word length
for I:= 0 to L do W(I):= W0(I);         \get working copy of word (including 0)
SS:= 20;                                \initialize best (saved) score
for C:= 1 to 1_000_000 do               \overkill? XPL0 is fast
        [I:= Ran(L);                    \shuffle: swap random char with end char
        T:= W(I);  W(I):= W(L-1);  W(L-1):= T;
        S:= 0;                          \compute score
        for I:= 0 to L-1 do
                if W(I) = W0(I) then S:= S+1;
        if S < SS then
                [SS:= S;                \save best score and best shuffle
                for I:= 0 to L do SW(I):= W(I);
                ];
        ];
Text(0, W0);  Text(0, ", ");            \show original and shuffled words, score
Text(0, SW);  Text(0, ", (");  IntOut(0, SS);  ChOut(0, ^));  CrLf(0);
];

int S, I;
[S:= ["abracadabra", "seesaw", "elk", "grrrrrr", "up", "a"];
for I:= 0 to 5 do Shuffle(S(I));
]


fcn bestShuffle(str){
   s:=str.split("").shuffle();    // -->List
   if(not s) return(str,str.len()); // can't shuffle "" or "a"

   n:=str.len();
   foreach i in (n){
      foreach j in (n){
         if (i!=j and s[i]!=str[j] and s[j]!=str[i]){
	    s.swap(i,j);
	    break;
	 }
      }
   }
   return(s.concat(), s.zipWith('==,str).sum(0));
}


program IntToBinTest;
{$MODE objFPC}
uses
  strutils;//IntToBin
function WholeIntToBin(n: NativeUInt):string;
var
  digits: NativeInt;
begin
// BSR?Word -> index of highest set bit but 0 -> 255 ==-1 )
  IF n <> 0 then
  Begin
{$ifdef CPU64}
    digits:= BSRQWord(NativeInt(n))+1;
{$ELSE}
    digits:= BSRDWord(NativeInt(n))+1;
{$ENDIF}
   WholeIntToBin := IntToBin(NativeInt(n),digits);
  end
  else
    WholeIntToBin:='0';
end;
procedure IntBinTest(n: NativeUint);
Begin
  writeln(n:12,' ',WholeIntToBin(n));
end;
BEGIN
  IntBinTest(5);IntBinTest(50);IntBinTest(5000);
  IntBinTest(0);IntBinTest(NativeUint(-1));
end.


10 FOR n=1 TO 6
20 READ w$
30 GO SUB 1000
40 LET count=0
50 FOR i=1 TO LEN w$
60 IF w$(i)=b$(i) THEN LET count=count+1
70 NEXT i
80 PRINT w$;" ";b$;" ";count
90 NEXT n
100 STOP
1000 REM Best shuffle
1010 LET b$=w$
1020 FOR i=1 TO LEN b$
1030 FOR j=1 TO LEN b$
1040 IF (i<>j) AND (b$(i)<>w$(j)) AND (b$(j)<>w$(i)) THEN LET t$=b$(i): LET b$(i)=b$(j): LET b$(j)=t$
1110 NEXT j
1120 NEXT i
1130 RETURN
2000 DATA "abracadabra","seesaw","elk","grrrrrr","up","a"


<@ defbaslit>2</@>

<@ saybaslit>0</@>
<@ saybaslit>5</@>
<@ saybaslit>50</@>
<@ saybaslit>9000</@>


def printBinary
    "The decimal value " print dup print " should produce an output of " print
    20 int>bit
    len 1 -1 3 tolist
    for
        get not
        if
            -1 del
        else
            exitfor
        endif
    endfor

    len 1 -1 3 tolist
    for
        get print
    endfor
    nl
enddef

5 printBinary
50 printBinary
9000 printBinary


<?php
echo decbin(5);
echo decbin(50);
echo decbin(9000);


  foreach(I in [5,50,900])
    println(to_binary_string(I))
  end.


100H:

/* CP/M BDOS CALL */
BDOS: PROCEDURE (FN, ARG);
    DECLARE FN BYTE, ARG ADDRESS;
    GO TO 5;
END BDOS;

/* PRINT STRING */
PRINT: PROCEDURE (STRING);
    DECLARE STRING ADDRESS;
    CALL BDOS(9, STRING);
END PRINT;

/* PRINT BINARY NUMBER */
PRINT$BINARY: PROCEDURE (N);
    DECLARE S (19) BYTE INITIAL ('................',13,10,'$');
    DECLARE (N, P) ADDRESS, C BASED P BYTE;
    P = .S(16);
BIT:
    P = P - 1;
    C = (N AND 1) + '0';
    IF (N := SHR(N,1)) <> 0 THEN GO TO BIT;
    CALL PRINT(P);
END PRINT$BINARY;

/* EXAMPLES FROM TASK */
DECLARE TEST (3) ADDRESS INITIAL (5, 50, 9000);
DECLARE I BYTE;

DO I = 0 TO LAST(TEST);
    CALL PRINT$BINARY(TEST(I));
END;

CALL BDOS(0,0);
EOF


#COMPILE EXE
#DIM ALL
#COMPILER PBCC 6

FUNCTION PBMAIN () AS LONG
LOCAL i, d() AS DWORD
REDIM d(2)
ARRAY ASSIGN d() = 5, 50, 9000
  FOR i = 0 TO 2
    PRINT STR$(d(i)) & ": " & BIN$(d(i)) & " (" & BIN$(d(i), 32) & ")"
  NEXT i
END FUNCTION


@(5,50,900) | foreach-object { [Convert]::ToString($_,2) }


println(Integer.toBinaryString(5));     //            101
println(Integer.toBinaryString(50));    //         110010
println(Integer.toBinaryString(9000));  // 10001100101000


binary(X) :- format('~2r~n', [X]).
main :- maplist(binary, [5,50,9000]), halt.


If OpenConsole()
  PrintN(Bin(5))    ;101
  PrintN(Bin(50))   ;110010
  PrintN(Bin(9000)) ;10001100101000

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


Print DecToBin$(5)
Print DecToBin$(50)
Print DecToBin$(9000)

Print BinToDec$(DecToBin$(5)) '  101
Print BinToDec$(DecToBin$(50)) '110010
Print BinToDec$(DecToBin$(9000)) ' 10001100101000

End

Function DecToBin$ (digit As Integer)
    DecToBin$ = "Error"
    If digit < 1 Then
        Print " Error number invalid for conversion to binary"
        DecToBin$ = "error of input"
        Exit Function
    Else

        Dim As Integer TempD
        Dim binaryD As String
        binaryD = ""
        TempD = digit
        Do
            binaryD = Right$(Str$(TempD Mod 2), 1) + binaryD
            TempD = TempD \ 2
        Loop Until TempD = 0
        DecToBin$ = binaryD
    End If
End Function

Function BinToDec$ (digitB As String)
    BinToDec$ = "Error"
    If Len(digitB) < 1 Then
        Print " Error number invalid for conversion to decimal"
        BinToDec$ = "error of input"
        Exit Function
    Else
        Dim As Integer TempD
        Dim binaryD As String
        binaryD = digitB
        TempD = 0
        Do
            TempD = TempD + ((2 ^ (Len(binaryD) - 1)) * Val(Left$(binaryD, 1)))
            binaryD = Right$(binaryD, Len(binaryD) - 1)
        Loop Until Len(binaryD) = 0
        BinToDec$ = LTrim$(Str$(TempD))
    End If
End Function


  2 base put    ( Numbers will be output in base 2 now.         )
                ( Bases from 2 to 36 (inclusive) are supported. )

  5    echo cr
  50   echo cr
  9000 echo cr

  base release  ( It's best to clean up after ourselves.        )
                ( Numbers will be output in base 10 now.        )


dec2bin <- function(num) {
  ifelse(num == 0,
         0,
         sub("^0+","",paste(rev(as.integer(intToBits(num))), collapse = ""))
  )
}

for (anumber in c(0, 5, 50, 9000)) {
         cat(dec2bin(anumber),"\n")
}


#lang racket
;; Option 1: binary formatter
(for ([i 16]) (printf "~b\n" i))
;; Option 2: explicit conversion
(for ([i 16]) (displayln (number->string i 2)))


'Convert Integer to binary string
Print "bin 5 = ", bin$(5)
Print "bin 50 = ",bin$(50)
Print "bin 9000 = ",bin$(9000)
sleep 10


Red []

foreach number [5 50 9000] [
  ;; any returns first not false value, used to cut leading zeroes
  binstr: form any [find enbase/base to-binary number 2 "1" "0"]
  print reduce [ pad/left number 5 binstr ]
]


9000 50 5  3 [ binary putn cr decimal ] times


/*REXX program to  convert  several  decimal numbers  to  binary  (or base 2).          */
                            numeric digits 1000  /*ensure we can handle larger numbers. */
@.=;             @.1=    0
                 @.2=    5
                 @.3=   50
                 @.4= 9000

  do j=1  while  @.j\==''                        /*compute until a  NULL value is found.*/
  y=x2b( d2x(@.j) )     + 0                      /*force removal of extra leading zeroes*/
  say right(@.j,20) 'decimal, and in binary:' y  /*display the number to the terminal.  */
  end   /*j*/                                    /*stick a fork in it,  we're all done. */


see "Number to convert : "
give a
n = 0
while pow(2,n+1) < a
      n = n + 1
end

for i = n to 0 step -1
    x = pow(2,i)
    if a >= x see 1 a = a - x
    else see 0 ok
next


input "Number to convert:";a
while 2^(n+1) < a
 n = n + 1
wend

for i = n to 0 step -1
  x = 2^i
  if a >= x then
    print 1;
    a = a - x
   else
    print 0;
  end if
next


fn main() {
    for i in 0..8 {
        println!("{:b}", i)
    }
}


define int_to_bin(d)
{
  variable m = 0x40000000, prn = 0, bs = "";
  do {
    if (d & m) {
      bs += "1";
      prn = 1;
    }
    else if (prn)
      bs += "0";
    m = m shr 1;

  } while (m);

  if (bs == "") bs = "0";
  return bs;
}

() = printf("%s\n", int_to_bin(5));
() = printf("%s\n", int_to_bin(50));
() = printf("%s\n", int_to_bin(9000));


scala> (5 toBinaryString)
res0: String = 101

scala> (50 toBinaryString)
res1: String = 110010

scala> (9000 toBinaryString)
res2: String = 10001100101000


(display (number->string 5 2)) (newline)
(display (number->string 50 2)) (newline)
(display (number->string 9000 2)) (newline)


$ include "seed7_05.s7i";

const proc: main is func
  local
    var integer: number is 0;
  begin
    for number range 0 to 16 do
      writeln(number radix 2);
    end for;
  end func;


main := toBinaryString([5, 50, 9000]);

toBinaryString(number(0)) :=
    let
        val := "1" when number mod 2 = 1 else "0";
    in
        toBinaryString(floor(number/2)) ++ val when floor(number/2) > 0
    else
        val;


BEGIN

    PROCEDURE OUTINTBIN(N); INTEGER N;
    BEGIN
        IF N > 1 THEN OUTINTBIN(N//2);
        OUTINT(MOD(N,2),1);
    END OUTINTBIN;

    INTEGER SAMPLE;
    FOR SAMPLE := 5, 50, 9000 DO BEGIN
        OUTINTBIN(SAMPLE);
        OUTIMAGE;
    END;

END


5 printOn: Stdout radix:2
50 printOn: Stdout radix:2
9000 printOn: Stdout radix:2


        define('bin(n,r)') :(bin_end)
bin   	bin = le(n,0) r :s(return)
	bin = bin(n / 2, REMDR(n,2) r) :(return)
bin_end

	output = bin(5)
	output = bin(50)
	output = bin(9000)
end


print (Int.fmt StringCvt.BIN 5 ^ "\n");
print (Int.fmt StringCvt.BIN 50 ^ "\n");
print (Int.fmt StringCvt.BIN 9000 ^ "\n");


for num in [5, 50, 9000] {
    println(String(num, radix: 2))
}


proc num2bin num {
    # Convert to _fixed width_ big-endian 32-bit binary
    binary scan [binary format "I" $num] "B*" binval
    # Strip useless leading zeros by reinterpreting as a big decimal integer
    scan $binval "%lld"
}


PROGRAM:BINARY
:Disp "NUMBER TO"
:Disp "CONVERT:"
:Input A
:0→N
:0→B
:While 2^(N+1)≤A
:N+1→N
:End
:While N≥0
:iPart(A/2^N)→C
:10^(N)*C+B→B
:If C=1
:Then
:A-2^N→A
:End
:N-1→N
:End
:Disp B


Do
  Input "Enter base (1<X<17): "; b
  While (b < 2) + (b > 16)
Loop

Input "Enter number: "; n
s = (n < 0)                            ' save the sign
n = Abs(n)                             ' make number unsigned

For x = 0 Step 1 Until n = 0           ' calculate all the digits
    @(x) = n % b
    n = n / b
Next x

If s Then Print "-";                   ' reapply the sign

For y = x - 1 To 0 Step -1             ' print all the digits
    If @(y) > 9 Then                   ' take care of hexadecimal digits
       Gosub @(y) * 10
    Else
       Print @(y);                     ' print "decimal" digits
    Endif
Next y

Print                                  ' finish the string
End

100 Print "A"; : Return                ' print hexadecimal digit
110 Print "B"; : Return
120 Print "C"; : Return
130 Print "D"; : Return
140 Print "E"; : Return
150 Print "F"; : Return


# Define a function to output binary digits
tobinary() {
  # We use the bench calculator for our conversion
  echo "obase=2;$1"|bc
}

# Call the function with each of our values
tobinary 5
tobinary 50


Option Explicit

Sub Main_Dec2bin()
Dim Nb As Long
Nb = 5
    Debug.Print "The decimal value " & Nb & " should produce an output of : " & DecToBin(Nb)
    Debug.Print "The decimal value " & Nb & " should produce an output of : " & DecToBin2(Nb)
Nb = 50
    Debug.Print "The decimal value " & Nb & " should produce an output of : " & DecToBin(Nb)
    Debug.Print "The decimal value " & Nb & " should produce an output of : " & DecToBin2(Nb)
Nb = 9000
    Debug.Print "The decimal value " & Nb & " should produce an output of : " & DecToBin(Nb)
    Debug.Print "The decimal value " & Nb & " should produce an output of : " & DecToBin2(Nb)
End Sub

Function DecToBin(ByVal Number As Long) As String
Dim strTemp As String

    Do While Number > 1
        strTemp = Number - 2 * (Number \ 2) & strTemp
        Number = Number \ 2
    Loop
    DecToBin = Number & strTemp
End Function

Function DecToBin2(ByVal Number As Long, Optional Places As Long) As String
    If Number > 511 Then
        DecToBin2 = "Error : Number is too large ! (Number must be < 511)"
    ElseIf Number < -512 Then
        DecToBin2 = "Error : Number is too small ! (Number must be > -512)"
    Else
        If Places = 0 Then
            DecToBin2 = WorksheetFunction.Dec2Bin(Number)
        Else
            DecToBin2 = WorksheetFunction.Dec2Bin(Number, Places)
        End If
    End If
End Function


repeat (ALL) {
    #10 = Get_Num("Give a numeric value, -1 to end: ", STATLINE)
    if (#10 < 0) { break }
    Call("BINARY")
    Update()
}
return

:BINARY:
do {
    Num_Ins(#10 & 1, LEFT+NOCR)
    #10 = #10 >> 1
    Char(-1)
} while (#10 > 0)
EOL
Ins_Newline
Return


function Num2Bin(n)
    let n = a:n
    let s = ""
    if n == 0
        let s = "0"
    else
        while n
            if n % 2 == 0
                let s = "0" . s
            else
                let s = "1" . s
            endif
            let n = n / 2
        endwhile
    endif
    return s
endfunction

echo Num2Bin(5)
echo Num2Bin(50)
echo Num2Bin(9000)


Public Function Bin(ByVal l As Long) As String
Dim i As Long
  If l Then
    If l And &H80000000 Then 'negative number
      Bin = "1" & String$(31, "0")
      l = l And (Not &H80000000)

      For i = 0 To 30
      If l And (2& ^ i) Then
        Mid$(Bin, Len(Bin) - i) = "1"
      End If
      Next i

    Else                     'positive number
      Do While l
      If l Mod 2 Then
        Bin = "1" & Bin
      Else
        Bin = "0" & Bin
      End If
      l = l \ 2
      Loop
    End If
  Else
    Bin = "0"                'zero
  End If
End Function

'testing:
Public Sub Main()
  Debug.Print Bin(5)
  Debug.Print Bin(50)
  Debug.Print Bin(9000)
End Sub


Module Program
    Sub Main
        For Each number In {5, 50, 9000}
            Console.WriteLine(Convert.ToString(number, 2))
        Next
    End Sub
End Module


*!* Binary Digits
CLEAR
k = CAST(5 As I)
? NToBin(k)
k = CAST(50 As I)
? NToBin(k)
k = CAST(9000 As I)
? NToBin(k)

FUNCTION NTOBin(n As Integer) As String
LOCAL i As Integer, b As String, v As Integer
b = ""
v = HiBit(n)
FOR i = 0 TO v
    b = IIF(BITTEST(n, i), "1", "0") + b
ENDFOR
RETURN b
ENDFUNC

FUNCTION HiBit(n As Double) As Integer
*!* Find the highest power of 2 in n
LOCAL v As Double
v = LOG(n)/LOG(2)
RETURN FLOOR(v)
ENDFUNC


fn main() {
	for i in 0..16 {
		println("${i:b}")
	}
}


\.toString 2
; the following function also casts the string to a number
^(@+ \.toString 2)


import "/fmt" for Fmt

System.print("Converting to binary:")
for (i in [5, 50, 9000]) Fmt.print("$d -> $b", i, i)


        .model  tiny
        .code
        .486
        org     100h
start:  mov     ax, 5
        call    binout
        call    crlf
        mov     ax, 50
        call    binout
        call    crlf
        mov     ax, 9000
        call    binout

crlf:   mov     al, 0Dh         ;new line
        int     29h
        mov     al, 0Ah
        int     29h
        ret

binout: push    ax
        shr     ax, 1
        je      bo10
         call   binout
bo10:   pop     ax
        and     al, 01h
        or      al, '0'
        int     29h             ;display character
        ret
        end     start


include c:\cxpl\codes;          \intrinsic code declarations

proc BinOut(N);                 \Output N in binary
int N;
int R;
[R:= N&1;
N:= N>>1;
if N then BinOut(N);
ChOut(0, R+^0);
];

int I;
[I:= 0;
repeat  BinOut(I); CrLf(0);
        I:= I+1;
until   KeyHit or I=0;
]


org &8000
PrintChar equ &BB5A   ;syscall - prints accumulator to Amstrad CPC's screen

main:

	ld hl,TestData0
	call PrintBinary_NoLeadingZeroes

	ld hl,TestData1
	call PrintBinary_NoLeadingZeroes

	ld hl,TestData2
	call PrintBinary_NoLeadingZeroes

	ret

TestData0:
	byte 5,255
TestData1:
	byte 5,0,255
TestData2:
	byte 9,0,0,0,255

temp:
    byte 0
	;temp storage for the accumulator
	;	we can't use the stack to preserve A since that would also preserve the flags.

PrintBinary_NoLeadingZeroes:
;setup:
	ld bc,&8000            ;B is the revolving bit mask, C is the "have we seen a zero yet" flag

NextDigit:
	ld a,(hl)
	inc hl
	cp 255
	jp z,Terminated

	ld (temp),a
NextBit:
	ld a,(temp)
	and b
	jr z,PrintZero
	; else, print one
	ld a,'1'                ;&31
	call &BB5A
	set 0,b			;bit 0 of B is now 1, so we can print zeroes now.
	jr Predicate

PrintZero:
	ld a,b
	or a
	jr z,Predicate		;if we haven't seen a zero yet, don't print a zero.
	ld a,'0'		;&30
	call &BB5A

Predicate:
	rrc b
	;rotate the mask right by one. If it sets the carry,
	;	it's back at the start, and we need to load the next byte.
	jr nc,NextBit

	jr NextDigit		;back to top

Terminated:
	ld a,13
	call &BB5A
	ld a,10
	jp &BB5A		;its ret will return for us.


10 LET n=5: GO SUB 1000: PRINT s$
20 LET n=50: GO SUB 1000: PRINT s$
30 LET n=9000: GO SUB 1000: PRINT s$
999 STOP
1000 REM convert to binary
1010 LET t=n: REM temporary variable
1020 LET s$="": REM this will contain our binary digits
1030 LET sf=0: REM output has not started yet
1040 FOR l=126 TO 0 STEP -1
1050 LET d$="0": REM assume next digit is zero
1060 IF t>=(2^l) THEN LET d$="1": LET t=t-(2^l): LET sf=1
1070 IF (sf <> 0) THEN LET s$=s$+d$
1080 NEXT l
1090 RETURN


BEGIN # find all primes with strictly increasing digits                      #
    PR read "primes.incl.a68" PR                   # include prime utilities #
    PR read "rows.incl.a68"   PR                   # include array utilities #
    [ 1 : 512 ]INT primes;         # there will be at most 512 (2^9) primes  #
    INT p count := 0;                        # number of primes found so far #
    FOR d1 FROM 0 TO 1 DO
        INT n1 = d1;
        FOR d2 FROM 0 TO 1 DO
            INT n2 = IF d2 = 1 THEN ( n1 * 10 ) + 2 ELSE n1 FI;
            FOR d3 FROM 0 TO 1 DO
                INT n3 = IF d3 = 1 THEN ( n2 * 10 ) + 3 ELSE n2 FI;
                FOR d4 FROM 0 TO 1 DO
                    INT n4 = IF d4 = 1 THEN ( n3 * 10 ) + 4 ELSE n3 FI;
                    FOR d5 FROM 0 TO 1 DO
                        INT n5 = IF d5 = 1 THEN ( n4 * 10 ) + 5 ELSE n4 FI;
                        FOR d6 FROM 0 TO 1 DO
                            INT n6 = IF d6 = 1 THEN ( n5 * 10 ) + 6 ELSE n5 FI;
                            FOR d7 FROM 0 TO 1 DO
                                INT n7 = IF d7 = 1 THEN ( n6 * 10 ) + 7 ELSE n6 FI;
                                FOR d8 FROM 0 TO 1 DO
                                    INT n8 = IF d8 = 1 THEN ( n7 * 10 ) + 8 ELSE n7 FI;
                                    FOR d9 FROM 0 TO 1 DO
                                        INT n9 = IF d9 = 1 THEN ( n8 * 10 ) + 9 ELSE n8 FI;
                                        IF n9 > 0 THEN
                                            IF is probably prime( n9 ) THEN
                                                # have a prime with strictly ascending digits #
                                                primes[ p count +:= 1 ] := n9
                                            FI
                                        FI
                                    OD
                                OD
                            OD
                        OD
                    OD
                OD
            OD
        OD
    OD;
    QUICKSORT primes FROMELEMENT 1 TOELEMENT p count;     # sort the primes #
    FOR i TO p count DO                                # display the primes #
        print( ( "  ", whole( primes[ i ], -8 ) ) );
        IF i MOD 10 = 0 THEN print( ( newline ) ) FI
    OD
END


ascending?: function [x][
    initial: digits x
    and? [equal? sort initial initial][equal? size initial size unique initial]
]

candidates: select (1..1456789) ++ [
    12345678, 12345679, 12345689, 12345789, 12346789,
    12356789, 12456789, 13456789, 23456789, 123456789
] => prime?

ascendingNums: select candidates => ascending?

loop split.every:10 ascendingNums 'nums [
    print map nums 'num -> pad to :string num 10
]


# syntax: GAWK -f ASCENDING_PRIMES.AWK
BEGIN {
    start = 1
    stop = 23456789
    for (i=start; i<=stop; i++) {
      if (is_prime(i)) {
        primes++
        leng = length(i)
        flag = 1
        for (j=1; j<leng; j++) {
          if (substr(i,j,1) >= substr(i,j+1,1)) {
            flag = 0
            break
          }
        }
        if (flag) {
          printf("%9d%1s",i,++count%10?"":"\n")
        }
      }
    }
    printf("\n%d-%d: %d primes, %d ascending primes\n",start,stop,primes,count)
    exit(0)
}
function is_prime(n,  d) {
    d = 5
    if (n < 2) { return(0) }
    if (n % 2 == 0) { return(n == 2) }
    if (n % 3 == 0) { return(n == 3) }
    while (d*d <= n) {
      if (n % d == 0) { return(0) }
      d += 2
      if (n % d == 0) { return(0) }
      d += 4
    }
    return(1)
}


// Ascending primes. Nigel Galloway: April 19th., 2022
[2;3;5;7]::List.unfold(fun(n,i)->match n with []->None |_->let n=n|>List.map(fun(n,g)->[for n in n.. -1..1->(n-1,i*n+g)])|>List.concat in Some(n|>List.choose(fun(_,n)->if isPrime n then Some n else None),(n|>List.filter(fst>>(<)0),i*10)))([(2,3);(6,7);(8,9)],10)
  |>List.concat|>List.sort|>List.iter(printf "%d "); printfn ""


USING: grouping math math.combinatorics math.functions
math.primes math.ranges prettyprint sequences sequences.extras ;

9 [1,b] all-subsets [ reverse 0 [ 10^ * + ] reduce-index ]
[ prime? ] map-filter 10 group simple-table.


package main

import (
    "fmt"
    "rcu"
    "sort"
)

var ascPrimesSet = make(map[int]bool) // avoids duplicates

func generate(first, cand, digits int) {
    if digits == 0 {
        if rcu.IsPrime(cand) {
            ascPrimesSet[cand] = true
        }
        return
    }
    for i := first; i < 10; i++ {
        next := cand*10 + i
        generate(i+1, next, digits-1)
    }
}

func main() {
    for digits := 1; digits < 10; digits++ {
        generate(1, 0, digits)
    }
    le := len(ascPrimesSet)
    ascPrimes := make([]int, le)
    i := 0
    for k := range ascPrimesSet {
        ascPrimes[i] = k
        i++
    }
    sort.Ints(ascPrimes)
    fmt.Println("There are", le, "ascending primes, namely:")
    for i := 0; i < le; i++ {
        fmt.Printf("%8d ", ascPrimes[i])
        if (i+1)%10 == 0 {
            fmt.Println()
        }
    }
}


# Output: the stream of ascending primes, in order
def ascendingPrimes:
  # Generate the stream of primes beginning with the digit .
  # and with strictly ascending digits, without regard to order
  def generate:
    # strings
    def g:
      . as $first
      | tonumber as $n
      | select($n <= 9)
      | $first,
        ((range($n + 1;10) | tostring | g) as $x
         | $first + $x );
    tostring | g | tonumber | select(is_prime);

  [range(1;10) | generate] | sort[];

def task:
  def lpad($len): tostring | ($len - length) as $l | (" " * $l)[:$l] + .;
  [ascendingPrimes]
  | "There are \(length) ascending primes, namely:",
    ( _nwise(10) | map(lpad(10)) | join(" ") );

task


using Combinatorics
using Primes

function ascendingprimes()
    return filter(isprime, [evalpoly(10, reverse(x))
       for x in powerset([1, 2, 3, 4, 5, 6, 7, 8, 9]) if !isempty(x)])
end

foreach(p -> print(rpad(p[2], 10), p[1] % 10 == 0 ? "\n" : ""), enumerate(ascendingprimes()))

@time ascendingprimes()


local function is_prime(n)
  if n < 2 then return false end
  if n % 2 == 0 then return n==2 end
  if n % 3 == 0 then return n==3 end
  for f = 5, n^0.5, 6 do
    if n%f==0 or n%(f+2)==0 then return false end
  end
  return true
end

local function ascending_primes()
  local digits, candidates, primes = {1,2,3,4,5,6,7,8,9}, {0}, {}
  for i = 1, #digits do
    for j = 1, #candidates do
      local value = candidates[j] * 10 + digits[i]
      if is_prime(value) then primes[#primes+1] = value end
      candidates[#candidates+1] = value
    end
  end
  table.sort(primes)
  return primes
end

print(table.concat(ascending_primes(), ", "))


[email protected][FromDigits /@ Subsets[[email protected], {1, \[Infinity]}], PrimeQ];
Multicolumn[ps, {Automatic, 6}, Appearance -> "Horizontal"]


#!/usr/bin/perl

use strict; # https://rosettacode.org/wiki/Ascending_primes
use warnings;
use ntheory qw( is_prime );

print join('', map { sprintf "%10d", $_ } sort { $a <=> $b }
  grep /./ && is_prime($_),
  glob join '', map "{$_,}", 1 .. 9) =~ s/.{50}\K/\n/gr;


with javascript_semantics
function ascending_primes(sequence res, atom p=0)
    for d=remainder(p,10)+1 to 9 do
        integer np = p*10+d
        if odd(d) and is_prime(np) then res &= np end if
        res = ascending_primes(res,np)
    end for
    return res
end function

sequence r = apply(true,sprintf,{{"%8d"},sort(ascending_primes({2}))})
printf(1,"There are %,d ascending primes:\n%s\n",{length(r),join_by(r,1,10," ")})


import util.

main =>
  DP = [N : S in power_set("123456789"), S != [], N = S.to_int, prime(N)].sort,
  foreach({P,I} in zip(DP,1..DP.len))
    printf("%9d%s",P,cond(I mod 10 == 0,"\n",""))
  end,
  nl,
  println(len=DP.len)


from sympy import isprime

def ascending(x=0):
    for y in range(x*10 + (x%10) + 1, x*10 + 10):
        yield from ascending(y)
        yield(y)

print(sorted(x for x in ascending() if isprime(x)))


  [ 0 swap witheach
      [ swap 10 * + ] ]                 is digits->n ( [ --> n )

  []
  ' [ 1 2 3 4 5 6 7 8 9 ] powerset
  witheach
    [ digits->n dup isprime
      iff join else drop ]
  sort echo


put (flat 2, 3, 5, 7, sort +*, gather (1..8).map: &recurse ).batch(10)».fmt("%8d").join: "\n";

sub recurse ($str) {
    .take for ($str X~ (3, 7, 9)).grep: { .is-prime && [<] .comb };
    recurse $str × 10 + $_ for $str % 10 ^.. 9;
}

printf "%.3f seconds", now - INIT now;


load "stdlibcore.ring"

limit = 1000
row = 0

for n = 1 to limit
    flag = 0
    strn = string(n)
    if isprime(n) = 1
       for m = 1 to len(strn)-1
           if number(substr(strn,m)) > number(substr(strn,m+1))
              flag = 1
           ok
       next
       if flag = 1
          row++
          see "" + n + " "
       ok
       if row % 10 = 0
          see nl
       ok
    ok
next


func primes_with_ascending_digits(base = 10) {

    var list = []
    var digits = @(1..^base -> flip)

    var end_digits = digits.grep { .is_coprime(base) }
    list << digits.grep { .is_prime && !.is_coprime(base) }...

    for k in (0 .. digits.end) {
        digits.combinations(k, {|*a|
            var v = a.digits2num(base)
            end_digits.each {|d|
                var n = (v*base + d)
                next if ((n >= base) && (a[0] >= d))
                list << n if (n.is_prime)
            }
        })
    }

    list.sort
}

var arr = primes_with_ascending_digits()

say "There are #{arr.len} ascending primes.\n"

arr.each_slice(10, {|*a|
    say a.map { '%8s' % _ }.join(' ')
})


fn is_prime(n int) bool {
    if n < 2 {
        return false
    } else if n%2 == 0 {
        return n == 2
    } else if n%3 == 0 {
        return n == 3
    } else {
        mut d := 5
        for d*d <= n {
            if n%d == 0 {
                return false
            }
            d += 2
            if n%d == 0 {
                return false
            }
            d += 4
        }
        return true
    }
}
fn generate(first int, cand int, digits int, mut asc map[int]bool) {
    if digits == 0 {
        if is_prime(cand) {
            asc[cand] = true
        }
        return
    }
    for i in first..10 {
        next := cand*10 + i
        generate(i+1, next, digits-1, mut asc)
    }
}

fn main() {
    mut asc_primes_set := map[int]bool{} // avoids duplicates

    for digits in 1..10 {
        generate(1, 0, digits, mut asc_primes_set)
    }
    le := asc_primes_set.keys().len
    mut asc_primes := []int{len: le}
    mut i := 0
    for k,_ in asc_primes_set {
        asc_primes[i] = k
        i++
    }
    asc_primes.sort()
    println("There are $le ascending primes, namely:")
    for q in 0..le {
        print("${asc_primes[q]:8} ")
        if (q+1)%10 == 0 {
            println('')
        }
    }
}


import "./math" for Int
import "./seq"  for Lst
import "./fmt"  for Fmt

var isAscending = Fn.new { |n|
    if (n < 10) return true
    var digits = Int.digits(n)
    for (i in 1...digits.count) {
        if (digits[i] <= digits[i-1]) return false
    }
    return true
}

var higherPrimes = []
var candidates = [
    12345678, 12345679, 12345689, 12345789, 12346789,
    12356789, 12456789, 13456789, 23456789, 123456789
]
for (cand in candidates) if (Int.isPrime(cand)) higherPrimes.add(cand)

var primes = Int.primeSieve(3456789)
var ascPrimes = []
for (p in primes) if (isAscending.call(p)) ascPrimes.add(p)
ascPrimes.addAll(higherPrimes)
System.print("There are %(ascPrimes.count) ascending primes, namely:")
for (chunk in Lst.chunks(ascPrimes, 10)) Fmt.print("$8d", chunk)


func IsPrime(N);        \Return 'true' if N is prime
int  N, I;
[if N <= 2 then return N = 2;
if (N&1) = 0 then \even >2\ return false;
for I:= 3 to sqrt(N) do
    [if rem(N/I) = 0 then return false;
    I:= I+1;
    ];
return true;
];

func Ascending(N);      \Return 'true' if digits are ascending
int  N, D;
[N:= N/10;
D:= rem(0);
while N do
    [N:= N/10;
    if rem(0) >= D then return false;
    D:= rem(0);
    ];
return true;
];

int Cnt, N;
[Cnt:= 0;
Format(9, 0);
for N:= 2 to 123_456_789 do
    if Ascending(N) then
        if IsPrime(N) then
            [RlOut(0, float(N));
            Cnt:= Cnt+1;
            if rem(Cnt/10) = 0 then CrLf(0);
            ];
]


INCLUDE "H6:REALMATH.ACT"

BYTE CH=$02FC,COLOR1=$02C5,COLOR2=$02C6
REAL r0,r4,r15,r16,r20,r22,r23,r24,r26,r28,r44,r85,r160

PROC Init()
  ValR("0",r0)
  ValR("0.04",r4)
  ValR("0.15",r16)
  ValR("0.16",r16)
  ValR("0.2",r20)
  ValR("0.22",r22)
  ValR("0.23",r23)
  ValR("0.24",r24)
  ValR("0.26",r26)
  ValR("0.28",r28)
  ValR("0.44",r44)
  ValR("0.85",r85)
  ValR("1.6",r160)
RETURN

PROC Fern(REAL POINTER scale)
  BYTE r
  REAL x,y,xp,yp,tmp1,tmp2
  INT i,ix,iy

  RealAssign(r0,x)
  RealAssign(r0,y)

  DO
    RealMult(x,scale,tmp1)
    RealMult(y,scale,tmp2)
    ix=Round(tmp2) ;fern is rotated to fit the screen size
    iy=Round(tmp1)+85

    IF (ix>=0) AND (ix<=319) AND (iy>=0) AND (iy<=191) THEN
      Plot(ix,iy)
    FI
    r=Rand(100)
    RealAssign(x,xp) ;xp=x
    RealAssign(y,yp) ;yp=y
    IF r<1 THEN
      RealAssign(r0,x)   ;x=0
      RealMult(r16,yp,y) ;y=0.16*yp
    ELSEIF r<86 THEN
      RealMult(r85,xp,tmp1) ;tmp1=0.85*xp
      RealMult(r4,yp,tmp2)  ;tmp2=0.4*yp
      RealAdd(tmp1,tmp2,x)  ;x=0.85*xp+0.4*yp

      RealMult(r4,xp,tmp1)    ;tmp1=0.04*xp
      RealSub(r160,tmp1,tmp2) ;tmp2=-0.04*xp+1.6
      RealMult(r85,yp,tmp1)   ;tmp1=0.85*yp
      RealAdd(tmp1,tmp2,y)    ;y=-0.04*xp+0.85*yp+1.6
    ELSEIF r<93 THEN
      RealMult(r20,xp,tmp1) ;tmp1=0.2*xp
      RealMult(r26,yp,tmp2) ;tmp2=0.26*yp
      RealSub(tmp1,tmp2,x)  ;x=0.2*xp-0.26*yp

      RealMult(r23,xp,tmp1)   ;tmp1=0.23*xp
      RealAdd(r160,tmp1,tmp2) ;tmp2=0.23*xp+1.6
      RealMult(r22,yp,tmp1)   ;tmp1=0.22*yp
      RealAdd(tmp1,tmp2,y)    ;y=0.23*xp+0.22*yp+1.6
    ELSE
      RealMult(r15,xp,tmp1) ;tmp1=0.15*xp
      RealMult(r28,yp,tmp2) ;tmp2=0.28*yp
      RealSub(tmp2,tmp1,x)  ;x=-0.15*xp+0.28*yp

      RealMult(r26,xp,tmp1)  ;tmp1=0.26*xp
      RealAdd(r44,tmp1,tmp2) ;tmp2=0.26*xp+0.44
      RealMult(r24,yp,tmp1)  ;tmp1=0.24*yp
      RealAdd(tmp1,tmp2,y)   ;y=0.26*xp+0.44*yp+0.44
    FI

    Poke(77,0) ;turn off the attract mode
  UNTIL CH#$FF ;until key pressed
  OD
  CH=$FF
RETURN

PROC Main()
  REAL scale

  Graphics(8+16)
  Color=1
  COLOR1=$BA
  COLOR2=$B2

  Init()
  ValR("30",scale)
  Fern(scale)
RETURN


with Ada.Numerics.Discrete_Random;

with SDL.Video.Windows.Makers;
with SDL.Video.Renderers.Makers;
with SDL.Events.Events;

procedure Barnsley_Fern is

   Iterations : constant := 1_000_000;
   Width      : constant := 500;
   Height     : constant := 750;
   Scale      : constant := 70.0;

   type Percentage is range 1 .. 100;
   package Random_Percentages is
      new Ada.Numerics.Discrete_Random (Percentage);

   Gen      : Random_Percentages.Generator;
   Window   : SDL.Video.Windows.Window;
   Renderer : SDL.Video.Renderers.Renderer;
   Event    : SDL.Events.Events.Events;

   procedure Draw_Barnsley_Fern is
      use type SDL.C.int;
      subtype F1_Range is Percentage range Percentage'First  .. Percentage'First;
      subtype F2_Range is Percentage range F1_Range'Last + 1 .. F1_Range'Last + 85;
      subtype F3_Range is Percentage range F2_Range'Last + 1 .. F2_Range'Last + 7;
      subtype F4_Range is Percentage range F3_Range'Last + 1 .. F3_Range'Last + 7;

      X0, Y0 : Float := 0.00;
      X1, Y1 : Float;
   begin
      for I in 1 .. Iterations loop
         case Random_Percentages.Random (Gen) is

            when F1_Range =>
               X1 := 0.00;
               Y1 := 0.16 * Y0;

            when F2_Range =>
               X1 :=  0.85 * X0 + 0.04 * Y0;
               Y1 := -0.04 * X0 + 0.85 * Y0 + 1.60;

            when F3_Range =>
               X1 := 0.20 * X0 - 0.26 * Y0;
               Y1 := 0.23 * X0 + 0.22 * Y0 + 1.60;

            when F4_Range =>
               X1 := -0.15 * X0 + 0.28 * Y0;
               Y1 :=  0.26 * X0 + 0.24 * Y0 + 0.44;

         end case;
         Renderer.Draw (Point => (X => Width / 2 + SDL.C.int (Scale * X1),
                                  Y => Height    - SDL.C.int (Scale * Y1)));
         X0 := X1; Y0 := Y1;

      end loop;
   end Draw_Barnsley_Fern;

   procedure Wait is
      use type SDL.Events.Event_Types;
   begin
      loop
         while SDL.Events.Events.Poll (Event) loop
            if Event.Common.Event_Type = SDL.Events.Quit then
               return;
            end if;
         end loop;
      end loop;
   end Wait;

begin
   if not SDL.Initialise (Flags => SDL.Enable_Screen) then
      return;
   end if;

   SDL.Video.Windows.Makers.Create (Win      => Window,
                                    Title    => "Barnsley Fern",
                                    Position => SDL.Natural_Coordinates'(X => 10, Y => 10),
                                    Size     => SDL.Positive_Sizes'(Width, Height),
                                    Flags    => 0);
   SDL.Video.Renderers.Makers.Create  (Renderer, Window.Get_Surface);
   Renderer.Set_Draw_Colour ((0, 0, 0, 255));
   Renderer.Fill (Rectangle => (0, 0, Width, Height));
   Renderer.Set_Draw_Colour ((0, 220, 0, 255));

   Random_Percentages.Reset (Gen);
   Draw_Barnsley_Fern;
   Window.Update_Surface;

   Wait;
   Window.Finalize;
   SDL.Finalise;
end Barnsley_Fern;


BEGIN
  INT iterations = 300000;
  LONG REAL scale x = 40, scale y = 40;
  [0:400,-200:200]CHAR canvas;

  LONG REAL x := 0, y := 0;

  FOR i FROM 1 LWB canvas TO 1 UPB canvas DO
    FOR j FROM 2 LWB canvas TO 2 UPB canvas DO
      canvas[i,j] := "0"
  OD OD;

  canvas[0, 0] := "1";
  TO iterations DO
    REAL choice := random;
    LONG REAL xn = x, yn = y;

    IF choice < 0.01 THEN
      x := 0;
      y := 0.16 * yn
    ELIF (choice -:= 0.01) < 0.85 THEN
      x :=  0.85 * xn + 0.04 * yn;
      y := -0.04 * xn + 0.85 * yn + 1.6
    ELIF (choice -:= 0.85) < 0.07 THEN
      x := 0.2  * xn - 0.26 * yn;
      y := 0.23 * xn + 0.22 * yn + 1.6
    ELSE
      x := -0.15 * xn + 0.28 * yn;
      y :=  0.26 * xn + 0.24 * yn + 0.44
    FI;

    INT px = SHORTEN ROUND (x * scale x),
        py = SHORTEN ROUND (y * scale y);
    IF px < 2 LWB canvas OR px > 2 UPB canvas OR
       py < 1 LWB canvas OR py > 1 UPB canvas
    THEN
      print(("resize canvas. px=", px, ", py=", py, new line));
      leave
    FI;

    canvas[py, px] := "1"
  OD;

  FILE f;
  IF establish(f, "fern.pbm", stand out channel) /= 0 THEN
    print("error creating file!"); leave
  FI;
  put(f, "P1"); new line(f);
  put(f, (whole((2 UPB canvas) - (2 LWB canvas) + 1, 0), " ",
          whole((1 UPB canvas) - (1 LWB canvas) + 1, 0), new line));
  FOR i FROM 1 UPB canvas BY -1 TO 1 LWB canvas DO
    put(f, canvas[i,]); new line(f)
  OD;
  close(f);
  leave: SKIP
END


# adjustable window altoght
# call the subroutine with the altoght you want
# it's possible to have a window that's large than your display
call barnsley(800)
end

subroutine barnsley(alto)
    graphsize alto / 2, alto
    color rgb(0, 255, 0)

    f = alto / 10.6
    c = alto / 4 - alto / 40
    x = 0 : y = 0

    for n = 1 to alto * 50
        p = rand * 100
        begin case
            case p <= 1
                nx = 0
                ny = 0.16 * y
            case p <= 8
                nx = 0.2  * x - 0.26 * y
                ny = 0.23 * x + 0.22 * y + 1.6
            case p <= 15
                nx = -0.15 * x + 0.28 * y
                ny =  0.26 * x + 0.24 * y + 0.44
            else
                nx =  0.85 * x + 0.04 * y
                ny = -0.04 * x + 0.85 * y + 1.6
        end case
        x = nx : y = ny
        plot(c + x * f, alto - y * f)
    next n

    # remove comment (#) in next line to save window as .png file
    # imgsave("Barnsley_fern.png")
end subroutine


      GCOL 2 : REM Green Graphics Color
      X=0 : Y=0
      FOR I%=1 TO 100000
        R%=RND(100)
        CASE TRUE OF
          WHEN R% == 1 NewX= 0                 : NewY= .16 * Y
          WHEN R% <  9 NewX= .20 * X - .26 * Y : NewY= .23 * X + .22 * Y + 1.6
          WHEN R% < 16 NewX=-.15 * X + .28 * Y : NewY= .26 * X + .24 * Y + .44
          OTHERWISE    NewX= .85 * X + .04 * Y : NewY=-.04 * X + .85 * Y + 1.6
        ENDCASE
        X=NewX : Y=NewY
        PLOT 1000 + X * 130 , Y * 130
      NEXT
      END


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

void barnsleyFern(int windowWidth, unsigned long iter){

	double x0=0,y0=0,x1,y1;
	int diceThrow;
	time_t t;
	srand((unsigned)time(&t));

	while(iter>0){
		diceThrow = rand()%100;

		if(diceThrow==0){
			x1 = 0;
			y1 = 0.16*y0;
		}

		else if(diceThrow>=1 && diceThrow<=7){
			x1 = -0.15*x0 + 0.28*y0;
			y1 = 0.26*x0 + 0.24*y0 + 0.44;
		}

		else if(diceThrow>=8 && diceThrow<=15){
			x1 = 0.2*x0 - 0.26*y0;
			y1 = 0.23*x0 + 0.22*y0 + 1.6;
		}

		else{
			x1 = 0.85*x0 + 0.04*y0;
			y1 = -0.04*x0 + 0.85*y0 + 1.6;
		}

		putpixel(30*x1 + windowWidth/2.0,30*y1,GREEN);

		x0 = x1;
		y0 = y1;

		iter--;
	}

}

int main()
{
	unsigned long num;

	printf("Enter number of iterations : ");
	scanf("%ld",&num);

	initwindow(500,500,"Barnsley Fern");

	barnsleyFern(500,num);

	getch();

	closegraph();

	return 0;
}


using System;
using System.Diagnostics;
using System.Drawing;

namespace RosettaBarnsleyFern
{
    class Program
    {
        static void Main(string[] args)
        {
            const int w = 600;
            const int h = 600;
            var bm = new Bitmap(w, h);
            var r = new Random();
            double x = 0;
            double y = 0;
            for (int count = 0; count < 100000; count++)
            {
                bm.SetPixel((int)(300 + 58 * x), (int)(58 * y), Color.ForestGreen);
                int roll = r.Next(100);
                double xp = x;
                if (roll < 1)
                {
                    x = 0;
                    y = 0.16 * y;
                } else if (roll < 86)
                {
                    x = 0.85 * x + 0.04 * y;
                    y = -0.04 * xp + 0.85 * y + 1.6;
                } else if (roll < 93)
                {
                    x = 0.2 * x - 0.26 * y;
                    y = 0.23 * xp + 0.22 * y + 1.6;
                } else
                {
                    x = -0.15 * x + 0.28 * y;
                    y = 0.26 * xp + 0.24 * y + 0.44;
                }
            }
            const string filename = "Fern.png";
            bm.Save(filename);
            Process.Start(filename);
        }
    }
}


#include <windows.h>
#include <ctime>
#include <string>

const int BMP_SIZE = 600, ITERATIONS = static_cast<int>( 15e5 );

class myBitmap {
public:
    myBitmap() : pen( NULL ), brush( NULL ), clr( 0 ), wid( 1 ) {}
    ~myBitmap() {
        DeleteObject( pen ); DeleteObject( brush );
        DeleteDC( hdc ); DeleteObject( bmp );
    }
    bool create( int w, int h ) {
        BITMAPINFO bi;
        ZeroMemory( &bi, sizeof( bi ) );
        bi.bmiHeader.biSize        = sizeof( bi.bmiHeader );
        bi.bmiHeader.biBitCount    = sizeof( DWORD ) * 8;
        bi.bmiHeader.biCompression = BI_RGB;
        bi.bmiHeader.biPlanes      = 1;
        bi.bmiHeader.biWidth       =  w;
        bi.bmiHeader.biHeight      = -h;
        HDC dc = GetDC( GetConsoleWindow() );
        bmp = CreateDIBSection( dc, &bi, DIB_RGB_COLORS, &pBits, NULL, 0 );
        if( !bmp ) return false;
        hdc = CreateCompatibleDC( dc );
        SelectObject( hdc, bmp );
        ReleaseDC( GetConsoleWindow(), dc );
        width = w; height = h;
        return true;
    }
    void clear( BYTE clr = 0 ) {
        memset( pBits, clr, width * height * sizeof( DWORD ) );
    }
    void setBrushColor( DWORD bClr ) {
        if( brush ) DeleteObject( brush );
        brush = CreateSolidBrush( bClr );
        SelectObject( hdc, brush );
    }
    void setPenColor( DWORD c ) {
        clr = c; createPen();
    }
    void setPenWidth( int w ) {
        wid = w; createPen();
    }
    void saveBitmap( std::string path ) {
        BITMAPFILEHEADER fileheader;
        BITMAPINFO       infoheader;
        BITMAP           bitmap;
        DWORD            wb;
        GetObject( bmp, sizeof( bitmap ), &bitmap );
        DWORD* dwpBits = new DWORD[bitmap.bmWidth * bitmap.bmHeight];
        ZeroMemory( dwpBits, bitmap.bmWidth * bitmap.bmHeight * sizeof( DWORD ) );
        ZeroMemory( &infoheader, sizeof( BITMAPINFO ) );
        ZeroMemory( &fileheader, sizeof( BITMAPFILEHEADER ) );
        infoheader.bmiHeader.biBitCount = sizeof( DWORD ) * 8;
        infoheader.bmiHeader.biCompression = BI_RGB;
        infoheader.bmiHeader.biPlanes = 1;
        infoheader.bmiHeader.biSize = sizeof( infoheader.bmiHeader );
        infoheader.bmiHeader.biHeight = bitmap.bmHeight;
        infoheader.bmiHeader.biWidth = bitmap.bmWidth;
        infoheader.bmiHeader.biSizeImage = bitmap.bmWidth * bitmap.bmHeight * sizeof( DWORD );
        fileheader.bfType    = 0x4D42;
        fileheader.bfOffBits = sizeof( infoheader.bmiHeader ) + sizeof( BITMAPFILEHEADER );
        fileheader.bfSize    = fileheader.bfOffBits + infoheader.bmiHeader.biSizeImage;
        GetDIBits( hdc, bmp, 0, height, ( LPVOID )dwpBits, &infoheader, DIB_RGB_COLORS );
        HANDLE file = CreateFile( path.c_str(), GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
            FILE_ATTRIBUTE_NORMAL, NULL );
        WriteFile( file, &fileheader, sizeof( BITMAPFILEHEADER ), &wb, NULL );
        WriteFile( file, &infoheader.bmiHeader, sizeof( infoheader.bmiHeader ), &wb, NULL );
        WriteFile( file, dwpBits, bitmap.bmWidth * bitmap.bmHeight * 4, &wb, NULL );
        CloseHandle( file );
        delete [] dwpBits;
    }
    HDC getDC() const     { return hdc; }
    int getWidth() const  { return width; }
    int getHeight() const { return height; }
private:
    void createPen() {
        if( pen ) DeleteObject( pen );
        pen = CreatePen( PS_SOLID, wid, clr );
        SelectObject( hdc, pen );
    }
    HBITMAP bmp; HDC    hdc;
    HPEN    pen; HBRUSH brush;
    void    *pBits; int    width, height, wid;
    DWORD    clr;
};
class fern {
public:
    void draw() {
        bmp.create( BMP_SIZE, BMP_SIZE );
        float x = 0, y = 0; HDC dc = bmp.getDC();
        int hs = BMP_SIZE >> 1;
        for( int f = 0; f < ITERATIONS; f++ ) {
            SetPixel( dc, hs + static_cast<int>( x * 55.f ),
                      BMP_SIZE - 15 - static_cast<int>( y * 55.f ),
                      RGB( static_cast<int>( rnd() * 80.f ) + 20,
                           static_cast<int>( rnd() * 128.f ) + 128,
                           static_cast<int>( rnd() * 80.f ) + 30 ) );
            getXY( x, y );
        }
        bmp.saveBitmap( "./bf.bmp" );
    }
private:
    void getXY( float& x, float& y ) {
        float g, xl, yl;
        g = rnd();
        if( g < .01f ) { xl = 0; yl = .16f * y; }
        else if( g < .07f ) {
            xl = .2f * x - .26f * y;
            yl = .23f * x + .22f * y + 1.6f;
        } else if( g < .14f ) {
            xl = -.15f * x + .28f * y;
            yl = .26f * x + .24f * y + .44f;
        } else {
            xl = .85f * x + .04f * y;
            yl = -.04f * x + .85f * y + 1.6f;
        }
        x = xl; y = yl;
    }
    float rnd() {
        return static_cast<float>( rand() ) / static_cast<float>( RAND_MAX );
    }
    myBitmap bmp;
};
int main( int argc, char* argv[]) {
    srand( static_cast<unsigned>( time( 0 ) ) );
    fern f; f.draw(); return 0;
}


F binary_search(l, value)
   V low = 0
   V high = l.len - 1
   L low <= high
      V mid = (low + high) I/ 2
      I l[mid] > value
         high = mid - 1
      E I l[mid] < value
         low = mid + 1
      E
         R mid
   R -1


(defpackage #:barnsley-fern
  (:use #:cl
        #:opticl))

(in-package #:barnsley-fern)

(defparameter *width* 800)
(defparameter *height* 800)
(defparameter *factor* (/ *height* 13))
(defparameter *x-offset* (/ *width* 2))
(defparameter *y-offset* (/ *height* 10))

(defun f1 (x y)
  (declare (ignore x))
  (values 0 (* 0.16 y)))

(defun f2 (x y)
  (values (+ (*  0.85 x) (* 0.04 y))
          (+ (* -0.04 x) (* 0.85 y) 1.6)))

(defun f3 (x y)
  (values (+ (* 0.2  x) (* -0.26 y))
          (+ (* 0.23 x) (*  0.22 y) 1.6)))

(defun f4 (x y)
  (values (+ (* -0.15 x) (* 0.28 y))
          (+ (*  0.26 x) (* 0.24 y) 0.44)))

(defun choose-transform ()
  (let ((r (random 1.0)))
    (cond ((< r 0.01) #'f1)
          ((< r 0.86) #'f2)
          ((< r 0.93) #'f3)
          (t          #'f4))))

(defun set-pixel (image x y)
  (let ((%x (round (+ (* *factor* x) *x-offset*)))
        (%y (round (- *height* (* *factor* y) *y-offset*))))
    (setf (pixel image %y %x) (values 0 255 0))))

(defun fern (filespec &optional (iterations 10000000))
  (let ((image (make-8-bit-rgb-image *height* *width* :initial-element 0))
        (x 0)
        (y 0))
    (dotimes (i iterations)
      (set-pixel image x y)
      (multiple-value-setq (x y) (funcall (choose-transform) x y)))
    (write-png-file filespec image)))


*        Binary search             05/03/2017
BINSEAR  CSECT
         USING  BINSEAR,R13        base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    save previous context
         ST     R13,4(R15)         link backward
         ST     R15,8(R13)         link forward
         LR     R13,R15            set addressability
         MVC    LOW,=H'1'          low=1
         MVC    HIGH,=AL2((XVAL-T)/2)  high=hbound(t)
         SR     R6,R6              i=0
         MVI    F,X'00'            f=false
         LH     R4,LOW             low
       DO WHILE=(CH,R4,LE,HIGH)    do while low<=high
         LA     R6,1(R6)             i=i+1
         LH     R1,LOW               low
         AH     R1,HIGH              +high
         SRA    R1,1                 /2  {by right shift}
         STH    R1,MID               mid=(low+high)/2
         SLA    R1,1                 *2
         LH     R7,T-2(R1)           y=t(mid)
       IF CH,R7,EQ,XVAL THEN         if xval=y then
         MVI    F,X'01'                f=true
         B      EXITDO                 leave
       ENDIF    ,                    endif
       IF CH,R7,GT,XVAL THEN         if y>xval then
         LH     R2,MID                 mid
         BCTR   R2,0                   -1
         STH    R2,HIGH                high=mid-1
       ELSE     ,                    else
         LH     R2,MID                 mid
         LA     R2,1(R2)               +1
         STH    R2,LOW                low=mid+1
       ENDIF    ,                    endif
         LH     R4,LOW               low
       ENDDO    ,                  enddo
EXITDO   EQU    *                exitdo:
         XDECO  R6,XDEC            edit i
         MVC    PG(4),XDEC+8       output i
         MVC    PG+4(6),=C' loops'
         XPRNT  PG,L'PG            print buffer
         LH     R1,XVAL            xval
         XDECO  R1,XDEC            edit xval
         MVC    PG(4),XDEC+8       output xval
       IF CLI,F,EQ,X'01' THEN      if f then
         MVC    PG+4(10),=C' found at '
         LH     R1,MID               mid
         XDECO  R1,XDEC              edit mid
         MVC    PG+14(4),XDEC+8      output mid
       ELSE     ,                  else
         MVC    PG+4(20),=C' is not in the list.'
       ENDIF    ,                  endif
         XPRNT  PG,L'PG            print buffer
         L      R13,4(0,R13)       restore previous savearea pointer
         LM     R14,R12,12(R13)    restore previous context
         XR     R15,R15            rc=0
         BR     R14                exit
T        DC     H'3',H'7',H'13',H'19',H'23',H'31',H'43',H'47'
         DC     H'61',H'73',H'83',H'89',H'103',H'109',H'113',H'131'
         DC     H'139',H'151',H'167',H'181',H'193',H'199',H'229',H'233'
         DC     H'241',H'271',H'283',H'293',H'313',H'317',H'337',H'349'
XVAL     DC     H'229'             <= search value
LOW      DS     H
HIGH     DS     H
MID      DS     H
F        DS     X                  flag
PG       DC     CL80' '            buffer
XDEC     DS     CL12               temp
         YREGS
         END    BINSEAR


#!/usr/bin/env dub
/+ dub.sdl:
	dependency "dlib" version="~>0.21.0"
+/
import std.random;

import dlib.image;

void main()
{
	enum WIDTH = 640;
	enum HEIGHT = 640;
	enum ITERATIONS = 2E6;

	float x = 0.0f;
	float y = 0.0f;

	auto rng = Random(unpredictableSeed);
	auto color = Color4f(0.0f, 1.0f, 0.0f);
	auto img = image(WIDTH, HEIGHT);

	foreach (_; 0..ITERATIONS)
	{
		auto r = uniform(0, 101, rng);

		if (r <= 1)
		{
			x = 0.0;
			y = 0.16 * y;
		}
		else
		{
			if (r <= 8)
			{
				x = 0.20 * x - 0.26 * y;
				y = 0.23 * x + 0.22 * y + 1.60;
			}
			else
			{
				if (r <= 15)
				{
					x = -0.15 * x + 0.28 * y;
					y = 0.26 * x + 0.24 * y + 0.44;
				}
				else
				{
					x = 0.85 * x + 0.04 * y;
					y = -0.04 * x + 0.85 * y + 1.6;
				}
			}
		}
		auto X = cast(int) (WIDTH / 2.0 + x * 60);
		auto Y =  HEIGHT - cast(int)(y * 60);
		img[X, Y] = color;
	}
	img.saveImage(`barnsley_dlib.png`);
}


		org	100h	; Entry for test code
		jmp	test

		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
		;; Binary search in array of unsigned 8-bit integers
		;; B = value to look for
		;; HL = begin of array (low)
		;; DE = end of array, inclusive (high)
		;; The entry point is 'binsrch'
		;; On return, HL = location of value (if contained
		;; in array), or insertion point (if not)

binsrch_lo:	inx	h	; low = mid + 1
		inx	sp	; throw away 'low'
		inx	sp

binsrch:	mov	a,d	; low > high? (are we there yet?)
		cmp	h	; test high byte
		rc
		mov	a,e	; test low byte
		cmp	l
		rc

		push	h	; store 'low'

		dad	d	; mid = (low+high)>>1
		mov	a,h	; rotate the carry flag back in
		rar		; to take care of any overflow
		mov	h,a
		mov	a,l
		rar
		mov	l,a

		mov	a,m	; A[mid] >= value?
		cmp	b
		jc	binsrch_lo

		xchg		; high = mid - 1
		dcx	d
		pop	h	; restore 'low'
		jmp	binsrch

		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
		;; Test data

primes:		db	2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37
		db	41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83
		db	89, 97, 101, 103, 107, 109, 113, 127, 131
		db	137, 139, 149, 151, 157, 163, 167, 173, 179
		db	181, 191, 193, 197, 199, 211, 223, 227, 229
		db	233, 239, 241, 251
primes_last:	equ	$ - 1

		;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
		;; Test code (CP/M compatible)

yep:		db	": yes", 13, 10, "$"
nope:		db	": no", 13, 10, "$"

num_out:	mov	a,b		;; Output number in B as decimal
		mvi	c,100
		call	dgt_out
		mvi	c,10
		call	dgt_out
		mvi	c,1
dgt_out:	mvi	e,'0' - 1	;; Output 100s, 10s or 1s
dgt_out_loop:	inr	e		;; (depending on C)
		sub	c
		jnc	dgt_out_loop
		add	c
e_out:		push	psw		;; Output character in E
		push	b		;; preserving working registers
		mvi	c,2
		call	5
		pop	b
		pop	psw
		ret

		;; Main test code
test:		mvi	b,0		; Test value

test_loop:	call	num_out		; Output current number to test

		lxi	h,primes	; Set up input for binary search
		lxi	d,primes_last
		call	binsrch		; Search for B in array

		lxi	d,nope		; Location of "no" string
		mov	a,b		; Check if location binsrch returned
		cmp	m		; contains the value we were looking for
		jnz	str_out		; If not, print the "no" string
		lxi	d,yep		; But if so, use location of "yes" string
str_out:	push	b		; Preserve B across CP/M call
		mvi	c,9		; Print the string
		call	5
		pop	b		; Restore B

		inr	b		; Test next value
		jnz	test_loop

		rst	0


unit Unit1;

interface

uses
  Windows, SysUtils, Graphics, Forms, Controls, Classes, ExtCtrls;

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure CreateFern(const w, h: integer);
var r, x, y: double;
    tmpx, tmpy: double;
    i: integer;
begin
    x := 0;
    y := 0;
    randomize();

    for i := 0 to 200000 do begin
        r := random(100000000) / 99999989;
        if r <= 0.01 then begin
            tmpx := 0;
            tmpy := 0.16 * y;
        end
        else if r <= 0.08 then begin
            tmpx := 0.2 * x - 0.26 * y;
            tmpy := 0.23 * x + 0.22 * y + 1.6;
        end
        else if r <= 0.15 then begin
            tmpx := -0.15 * x + 0.28 * y;
            tmpy := 0.26 * x + 0.24 * y + 0.44;
        end
        else begin
            tmpx := 0.85 * x + 0.04 * y;
            tmpy := -0.04 * x + 0.85 * y + 1.6;
        end;
        x := tmpx;
        y := tmpy;

        Form1.PaintBox1.Canvas.Pixels[round(w / 2 + x * w / 11), round(h - y * h / 11)] := clGreen;
    end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
    CreateFern(Form1.ClientWidth, Form1.ClientHeight);
end;

end.