@echo off
setlocal enabledelayedexpansion

	%== Initializations ==%
set width=50
set height=30

set /a allowance=height+2
mode %width%,%allowance%
echo Rendering...

set "outp="
for /l %%i in (1,1,%height%) do (
	for /l %%j in (1,1,%width%) do (
		set "c[%%i][%%j]= "
	)
)

	%== Set the parameters for making circle ==%
call :DrawCircle 20 20 10
call :DrawCircle 10 30 15

	%== Output result ==%
for /l %%i in (1,1,%height%) do (
	for /l %%j in (1,1,%width%) do (
		set "outp=!outp!!c[%%i][%%j]!"
	)
)
cls
echo !outp!
pause>nul
exit /b

	%== The main function ==%
:DrawCircle
	set x0=%1
	set y0=%2
	set radius=%3

	set x=!radius!
	set y=0
	set /a decisionOver2 = 1 - !x!

	:circle_loop
	if !x! geq !y! (
		set /a "hor=x + x0","ver=y + y0"
		set "c[!hor!][!ver!]=Û"
		set /a "hor=y + x0","ver=x + y0"
		set "c[!hor!][!ver!]=Û"
		set /a "hor=-x + x0","ver=y + y0"
		set "c[!hor!][!ver!]=Û"
		set /a "hor=-y + x0","ver=x + y0"
		set "c[!hor!][!ver!]=Û"
		set /a "hor=-x + x0","ver=-y + y0"
		set "c[!hor!][!ver!]=Û"
		set /a "hor=-y + x0","ver=-x + y0"
		set "c[!hor!][!ver!]=Û"
		set /a "hor=x + x0","ver=-y + y0"
		set "c[!hor!][!ver!]=Û"
		set /a "hor=y + x0","ver=-x + y0"
		set "c[!hor!][!ver!]=Û"

		set /a y+=1
		if !decisionOver2! leq 0 (
			set /a "decisionOver2 = !decisionOver2! + (2 * y^) + 1"
		) else (
			set /a x-=1
			set /a "decisionOver2 = !decisionOver2! + 2 * (y - x^) + 1"
		)
		goto circle_loop
	)
goto :EOF


      Width% = 200
      Height% = 200

      REM Set window size:
      VDU 23,22,Width%;Height%;8,16,16,128

      REM Draw circles:
      PROCcircle(100,100,40, 0,0,0)
      PROCcircle(100,100,80, 255,0,0)
      END

      DEF PROCcircle(cx%,cy%,r%,R%,G%,B%)
      LOCAL f%, x%, y%, ddx%, ddy%
      f% = 1 - r% : y% = r% : ddy% = - 2*r%
      PROCsetpixel(cx%, cy%+r%, R%,G%,B%)
      PROCsetpixel(cx%, cy%-r%, R%,G%,B%)
      PROCsetpixel(cx%+r%, cy%, R%,G%,B%)
      PROCsetpixel(cx%-r%, cy%, R%,G%,B%)
      WHILE x% < y%
        IF f% >= 0 THEN
          y% -= 1
          ddy% += 2
          f% += ddy%
        ENDIF
        x% += 1
        ddx% += 2
        f% += ddx% + 1
        PROCsetpixel(cx%+x%, cy%+y%, R%,G%,B%)
        PROCsetpixel(cx%-x%, cy%+y%, R%,G%,B%)
        PROCsetpixel(cx%+x%, cy%-y%, R%,G%,B%)
        PROCsetpixel(cx%-x%, cy%-y%, R%,G%,B%)
        PROCsetpixel(cx%+y%, cy%+x%, R%,G%,B%)
        PROCsetpixel(cx%-y%, cy%+x%, R%,G%,B%)
        PROCsetpixel(cx%+y%, cy%-x%, R%,G%,B%)
        PROCsetpixel(cx%-y%, cy%-x%, R%,G%,B%)
      ENDWHILE
      ENDPROC

      DEF PROCsetpixel(x%,y%,r%,g%,b%)
      COLOUR 1,r%,g%,b%
      GCOL 1
      LINE x%*2,y%*2,x%*2,y%*2
      ENDPROC


void raster_circle(
        image img,
        unsigned int x0,
        unsigned int y0,
        unsigned int radius,
        color_component r,
        color_component g,
        color_component b );


        /// <summary>
        /// Draws a circle.
        /// </summary>
        /// <param name="image">
        /// The destination image.
        /// </param>
        /// <param name="centerX">
        /// The x center position of the circle.
        /// </param>
        /// <param name="centerY">
        /// The y center position of the circle.
        /// </param>
        /// <param name="radius">
        /// The radius of the circle.
        /// </param>
        /// <param name="color">
        /// The color to use.
        /// </param>
        public static void DrawCircle(this GenericImage image, int centerX, int centerY, int radius, Color color)
        {
            int d = (5 - radius * 4) / 4;
            int x = 0;
            int y = radius;

            do
            {
                // ensure index is in range before setting (depends on your image implementation)
                // in this case we check if the pixel location is within the bounds of the image before setting the pixel
                if (centerX + x >= 0 && centerX + x <= image.Width - 1 && centerY + y >= 0 && centerY + y <= image.Height - 1) image[centerX + x, centerY + y] = color;
                if (centerX + x >= 0 && centerX + x <= image.Width - 1 && centerY - y >= 0 && centerY - y <= image.Height - 1) image[centerX + x, centerY - y] = color;
                if (centerX - x >= 0 && centerX - x <= image.Width - 1 && centerY + y >= 0 && centerY + y <= image.Height - 1) image[centerX - x, centerY + y] = color;
                if (centerX - x >= 0 && centerX - x <= image.Width - 1 && centerY - y >= 0 && centerY - y <= image.Height - 1) image[centerX - x, centerY - y] = color;
                if (centerX + y >= 0 && centerX + y <= image.Width - 1 && centerY + x >= 0 && centerY + x <= image.Height - 1) image[centerX + y, centerY + x] = color;
                if (centerX + y >= 0 && centerX + y <= image.Width - 1 && centerY - x >= 0 && centerY - x <= image.Height - 1) image[centerX + y, centerY - x] = color;
                if (centerX - y >= 0 && centerX - y <= image.Width - 1 && centerY + x >= 0 && centerY + x <= image.Height - 1) image[centerX - y, centerY + x] = color;
                if (centerX - y >= 0 && centerX - y <= image.Width - 1 && centerY - x >= 0 && centerY - x <= image.Height - 1) image[centerX - y, centerY - x] = color;
                if (d < 0)
                {
                    d += 2 * x + 1;
                }
                else
                {
                    d += 2 * (x - y) + 1;
                    y--;
                }
                x++;
            } while (x <= y);
        }


(defn draw-circle [draw-function x0 y0 radius]
  (letfn [(put [x y m]
            (let [x+ (+ x0 x)
                  x- (- x0 x)
                  y+ (+ y0 y)
                  y- (- y0 y)
                  x0y+ (+ x0 y)
                  x0y- (- x0 y)
                  xy0+ (+ y0 x)
                  xy0- (- y0 x)]
              (draw-function x+ y+)
              (draw-function x+ y-)
              (draw-function x- y+)
              (draw-function x- y-)
              (draw-function x0y+ xy0+)
              (draw-function x0y+ xy0-)
              (draw-function x0y- xy0+)
              (draw-function x0y- xy0-)
              (let [[y m] (if (pos? m)
                            [(dec y) (- m (* 8 y))]
                            [y m])]
                (when (<= x y)
                  (put (inc x)
                       y
                       (+ m 4 (* 8 x)))))))]
    (put 0 radius (- 5 (* 4 radius)))))


(defun draw-circle (draw-function x0 y0 radius)
  (labels ((foo (x y)
             (funcall draw-function x y))
           (put (x y m)
             (let ((x+ (+ x0 x))
                   (x- (- x0 x))
                   (y+ (+ y0 y))
                   (y- (- y0 y))
                   (x0y+ (+ x0 y))
                   (x0y- (- x0 y))
                   (xy0+ (+ y0 x))
                   (xy0- (- y0 x)))
               (foo x+ y+)
               (foo x+ y-)
               (foo x- y+)
               (foo x- y-)
               (foo x0y+ xy0+)
               (foo x0y+ xy0-)
               (foo x0y- xy0+)
               (foo x0y- xy0-)
               (multiple-value-bind (y m) (if (plusp m)
                                              (values (1- y) (- m (* 8 y)))
                                              (values y m))
                 (when (<= x y)
                   (put (1+ x)
                        y
                        (+ m 4 (* 8 x))))))))
    (put 0 radius (- 5 (* 4 radius)))
    (values)))


import bitmap: Image, RGB;

void circle(Color)(Image!Color img, in int x0, in int y0,
                   in int radius, in Color color)
pure nothrow @nogc @safe {
    int f = 1 - radius;
    int ddfX = 1;
    int ddfY = -2 * radius;
    int x = 0;
    int y = radius;
    img[x0, y0 + radius] = color;
    img[x0, y0 - radius] = color;
    img[x0 + radius, y0] = color;
    img[x0 - radius, y0] = color;

    while (x < y) {
        if (f >= 0) {
            y--;
            ddfY += 2;
            f += ddfY;
        }
        x++;
        ddfX += 2;
        f += ddfX;
        img[x0 + x, y0 + y] = color;
        img[x0 - x, y0 + y] = color;
        img[x0 + x, y0 - y] = color;
        img[x0 - x, y0 - y] = color;
        img[x0 + y, y0 + x] = color;
        img[x0 - y, y0 + x] = color;
        img[x0 + y, y0 - x] = color;
        img[x0 - y, y0 - x] = color;
    }
}

void main() @safe {
    auto img = new Image!RGB(25, 25);
    img.clear(RGB.white);
    circle(img, 12, 12, 12, RGB.black);
    img.textualShow;
}


PROGRAM BCircle

!$INCLUDE="PC.LIB"

PROCEDURE BCircle(cx%,cy%,r%)
      local f%,x%,y%,ddx%,ddy%
      f%=1-r%  y%=r%  ddy%=-2*r%
      PSET(cx%,cy%+r%,1)
      PSET(cx%,cy%-r%,1)
      PSET(cx%+r%,cy%,1)
      PSET(cx%-r%,cy%,1)
      WHILE x%<y% DO
        IF f%>=0 THEN
          y%=y%-1
          ddy%=ddy%+2
          f%=f%+ddy%
        END IF
        x%=x%+1
        ddx%=ddx%+2
        f%=f%+ddx%+1
        PSET(cx%+x%,cy%+y%,1)
        PSET(cx%-x%,cy%+y%,1)
        PSET(cx%+x%,cy%-y%,1)
        PSET(cx%-x%,cy%-y%,1)
        PSET(cx%+y%,cy%+x%,1)
        PSET(cx%-y%,cy%+x%,1)
        PSET(cx%+y%,cy%-x%,1)
        PSET(cx%-y%,cy%-x%,1)
      END WHILE
END PROCEDURE

BEGIN
      SCREEN(1)
      ! Draw circles
      BCircle(100,100,40)
      BCircle(100,100,80)
END PROGRAM


#DEFINE WM_LBUTTONDOWN 513
#DEFINE WM_CLOSE 16

FBSLSETTEXT(ME, "Bresenham Circle") ' Set form caption
FBSLSETFORMCOLOR(ME, RGB(0, 255, 255)) ' Cyan: persistent background color
FBSL.GETDC(ME) ' Use volatile FBSL.GETDC below to avoid extra assignments

RESIZE(ME, 0, 0, 220, 220)
CENTER(ME)
SHOW(ME)

DIM Breadth AS INTEGER, Height AS INTEGER
FBSL.GETCLIENTRECT(ME, 0, 0, Breadth, Height)

BEGIN EVENTS ' Main message loop
	SELECT CASE CBMSG
		CASE WM_LBUTTONDOWN: MidpointCircle() ' Draw
		CASE WM_CLOSE: FBSL.RELEASEDC(ME, FBSL.GETDC) ' Clean up
	END SELECT
END EVENTS

SUB MidpointCircle()
	BresenhamCircle(Breadth \ 2, Height \ 2, 80, &HFF) ' Red: Windows stores colors in BGR order
	BresenhamCircle(Breadth \ 2, Height \ 2, 40, 0) ' Black

	SUB BresenhamCircle(cx, cy, radius, colour)
		DIM x = 0, y = radius, f = 1 - radius, dx = 0, dy = -2 * radius

		PSET(FBSL.GETDC, cx, cy + radius, colour)(FBSL.GETDC, cx, cy - radius, colour)
		PSET(FBSL.GETDC, cx + radius, cy, colour)(FBSL.GETDC, cx - radius, cy, colour)

		WHILE x < y
			IF f >= 0 THEN: DECR(y): INCR(dy, 2)(f, dy): END IF ' Try also "IF f THEN" :)
			INCR(x)(dx, 2)(f, dx + 1)
			PSET(FBSL.GETDC, cx + x, cy + y, colour)(FBSL.GETDC, cx - x, cy + y, colour)
			PSET(FBSL.GETDC, cx + x, cy - y, colour)(FBSL.GETDC, cx - x, cy - y, colour)
			PSET(FBSL.GETDC, cx + y, cy + x, colour)(FBSL.GETDC, cx - y, cy + x, colour)
			PSET(FBSL.GETDC, cx + y, cy - x, colour)(FBSL.GETDC, cx - y, cy - x, colour)
		WEND
	END SUB
END SUB


: circle { x y r color bmp -- }
  1 r -  0 r 2* negate  0 r  { f ddx ddy dx dy }
  color x     y r + bmp b!
  color x     y r - bmp b!
  color x r + y     bmp b!
  color x r - y     bmp b!
  begin dx dy < while
    f 0< 0= if
      dy  1-      to dy
      ddy 2 + dup to ddy
      f +         to f
    then
    dx 1+       to dx
    ddx 2 + dup to ddx
    f 1+ +      to f
    color x dx + y dy + bmp b!
    color x dx - y dy + bmp b!
    color x dx + y dy - bmp b!
    color x dx - y dy - bmp b!
    color x dy + y dx + bmp b!
    color x dy - y dx + bmp b!
    color x dy + y dx - bmp b!
    color x dy - y dx - bmp b!
  repeat ;

12 12 bitmap value test
0 test bfill
6 6 5 blue test circle
test bshow cr


interface draw_circle
   module procedure draw_circle_sc, draw_circle_rgb
end interface

private :: plot, draw_circle_toch


' version 15-10-2016
' compile with: fbc -s gui

' Variant with Integer-Based Arithmetic from Wikipedia page:
' Midpoint circle algorithm
Sub circle_(x0 As Integer, y0 As Integer , radius As Integer, Col As Integer)

  Dim As Integer x = radius
  Dim As Integer y
  ' Decision criterion divided by 2 evaluated at x=r, y=0
  Dim As Integer decisionOver2 = 1 - x

  While(x >= y)
    PSet(x0 + x, y0 + y), col
    PSet(x0 - x, y0 + y), col
    PSet(x0 + x, y0 - y), col
    PSet(x0 - x, y0 - y), col
    PSet(x0 + y, y0 + x), col
    PSet(x0 - y, y0 + x), col
    PSet(x0 + y, y0 - x), col
    PSet(x0 - y, y0 - x), col
    y = y +1
    If decisionOver2 <= 0 Then
      decisionOver2 += y * 2 +1 ' Change in decision criterion for y -> y +1
    Else
      x = x -1
      decisionOver2 += (y - x) * 2 +1  '  Change for y -> y +1, x -> x -1
    End If
  Wend

End Sub

' ------=< MAIN >=------

ScreenRes 600, 600, 32
Dim As Integer w, h, depth
Randomize Timer

ScreenInfo w, h

For i As Integer = 1 To 10
  circle_(Rnd * w,  Rnd * h , Rnd * 200 , Int(Rnd *&hFFFFFF))
Next

'save screen to BMP file
BSave "Name.BMP", 0

' empty keyboard buffer
While Inkey <> "" : Wend
WindowTitle "hit any key to end program"
Sleep
End


package raster

// Circle plots a circle with center x, y and radius r.
// Limiting behavior:
// r < 0 plots no pixels.
// r = 0 plots a single pixel at x, y.
// r = 1 plots four pixels in a diamond shape around the center pixel at x, y.
func (b *Bitmap) Circle(x, y, r int, p Pixel) {
    if r < 0 {
        return
    }
    // Bresenham algorithm
    x1, y1, err := -r, 0, 2-2*r
    for {
        b.SetPx(x-x1, y+y1, p)
        b.SetPx(x-y1, y-x1, p)
        b.SetPx(x+x1, y-y1, p)
        b.SetPx(x+y1, y+x1, p)
        r = err
        if r > x1 {
            x1++
            err += x1*2 + 1
        }
        if r <= y1 {
            y1++
            err += y1*2 + 1
        }
        if x1 >= 0 {
            break
        }
    }
}

func (b *Bitmap) CircleRgb(x, y, r int, c Rgb) {
    b.Circle(x, y, r, c.Pixel())
}


module Circle where

import Data.List

type Point = (Int, Int)

-- Takes the center of the circle and radius, and returns the circle points
generateCirclePoints :: Point -> Int -> [Point]
generateCirclePoints (x0, y0) radius
  -- Four initial points, plus the generated points
  = (x0, y0 + radius) : (x0, y0 - radius) : (x0 + radius, y0) : (x0 - radius, y0) : points
    where
      -- Creates the (x, y) octet offsets, then maps them to absolute points in all octets.
      points = concatMap generatePoints $ unfoldr step initialValues
      generatePoints (x, y)
        = [(xop x0 x', yop y0 y') | (x', y') <- [(x, y), (y, x)], xop <- [(+), (-)], yop <- [(+), (-)]]

      -- The initial values for the loop
      initialValues = (1 - radius, 1, (-2) * radius, 0, radius)

      -- One step of the loop. The loop itself stops at Nothing.
      step (f, ddf_x, ddf_y, x, y) | x >= y = Nothing
                                   | otherwise = Just ((x', y'), (f', ddf_x', ddf_y', x', y'))
                                     where
                                       (f', ddf_y', y') | f >= 0 = (f + ddf_y' + ddf_x', ddf_y + 2, y - 1)
                                                        | otherwise = (f + ddf_x, ddf_y, y)
                                       ddf_x' = ddf_x + 2
                                       x' = x + 1


NB.*getBresenhamCircle v Returns points for a circle given center and radius
NB. y is: y0 x0 radius
getBresenhamCircle=: monad define
  'y0 x0 radius'=. y
  x=. 0
  y=. radius
  f=. -. radius
  pts=. 0 2$0
  while. x <: y do.
    pts=. pts , y , x
    if. f >: 0 do.
      y=. <:y
      f=. f + _2 * y
    end.
    x=. >:x
    f =. f + >: 2 * x
  end.
  offsets=. (,|."1) (1 _1 {~ #: i.4) *"1"1 _ pts
  ~.,/ (y0,x0) +"1 offsets
)

NB.*drawCircles v Draws circle(s) (x) on image (y)
NB. x is: 2-item list of boxed (y0 x0 radius) ; (color)
drawCircles=: (1&{:: ;~ [: ; [: <@getBresenhamCircle"1 (0&{::))@[ setPixels ]


import java.awt.Color;

public class MidPointCircle {
	private BasicBitmapStorage image;

	public MidPointCircle(final int imageWidth, final int imageHeight) {
		this.image = new BasicBitmapStorage(imageWidth, imageHeight);
	}

	private void drawCircle(final int centerX, final int centerY, final int radius) {
		int d = (5 - r * 4)/4;
		int x = 0;
		int y = radius;
		Color circleColor = Color.white;

		do {
			image.setPixel(centerX + x, centerY + y, circleColor);
			image.setPixel(centerX + x, centerY - y, circleColor);
			image.setPixel(centerX - x, centerY + y, circleColor);
			image.setPixel(centerX - x, centerY - y, circleColor);
			image.setPixel(centerX + y, centerY + x, circleColor);
			image.setPixel(centerX + y, centerY - x, circleColor);
			image.setPixel(centerX - y, centerY + x, circleColor);
			image.setPixel(centerX - y, centerY - x, circleColor);
			if (d < 0) {
				d += 2 * x + 1;
			} else {
				d += 2 * (x - y) + 1;
				y--;
			}
			x++;
		} while (x <= y);

	}
}


function drawcircle!(img::Matrix{T}, col::T, x0::Int, y0::Int, radius::Int) where T
    x = radius - 1
    y = 0
    δx = δy = 1
    er = δx - (radius << 1)

    s = x + y
    while x ≥ y
        for opx in (+, -), opy in (+, -), el in (x, y)
            @inbounds img[opx(x0, el) + 1, opy(y0, s - el) + 1] = col
        end
        if er ≤ 0
            y  += 1
            er += δy
            δy += 2
        end
        if er > 0
            x  -= 1
            δx += 2
            er += (-radius << 1) + δx
        end
        s = x + y
    end
    return img
end

# Test
using Images

img = fill(Gray(255.0), 25, 25);
drawcircle!(img, Gray(0.0), 12, 12, 12)


function Bitmap:circle(x, y, r, c)
  local dx, dy, err = r, 0, 1-r
  while dx >= dy do
    self:set(x+dx, y+dy, c)
    self:set(x-dx, y+dy, c)
    self:set(x+dx, y-dy, c)
    self:set(x-dx, y-dy, c)
    self:set(x+dy, y+dx, c)
    self:set(x-dy, y+dx, c)
    self:set(x+dy, y-dx, c)
    self:set(x-dy, y-dx, c)
    dy = dy + 1
    if err < 0 then
      err = err + 2 * dy + 1
    else
      dx, err = dx-1, err + 2 * (dy - dx) + 1
    end
  end
end


// version 1.1.4-3

import java.awt.Color
import java.awt.Graphics
import java.awt.image.BufferedImage
import javax.swing.JOptionPane
import javax.swing.JLabel
import javax.swing.ImageIcon

class BasicBitmapStorage(width: Int, height: Int) {
    val image = BufferedImage(width, height, BufferedImage.TYPE_3BYTE_BGR)

    fun fill(c: Color) {
        val g = image.graphics
        g.color = c
        g.fillRect(0, 0, image.width, image.height)
    }

    fun setPixel(x: Int, y: Int, c: Color) = image.setRGB(x, y, c.getRGB())

    fun getPixel(x: Int, y: Int) = Color(image.getRGB(x, y))
}

fun drawCircle(bbs: BasicBitmapStorage, centerX: Int, centerY: Int, radius: Int, circleColor: Color) {
    var d = (5 - radius * 4) / 4
    var x = 0
    var y = radius

    do {
        with(bbs) {
            setPixel(centerX + x, centerY + y, circleColor)
            setPixel(centerX + x, centerY - y, circleColor)
            setPixel(centerX - x, centerY + y, circleColor)
            setPixel(centerX - x, centerY - y, circleColor)
            setPixel(centerX + y, centerY + x, circleColor)
            setPixel(centerX + y, centerY - x, circleColor)
            setPixel(centerX - y, centerY + x, circleColor)
            setPixel(centerX - y, centerY - x, circleColor)
        }
        if (d < 0) {
            d += 2 * x + 1
        }
        else {
            d += 2 * (x - y) + 1
            y--
        }
        x++
    }
    while (x <= y)
}

fun main(args: Array<String>) {
    val bbs = BasicBitmapStorage(400, 400)
    bbs.fill(Color.pink)
    drawCircle(bbs, 200, 200, 100, Color.black)
    drawCircle(bbs, 200, 200,  50, Color.white)
    val label = JLabel(ImageIcon(bbs.image))
    val title = "Bresenham's circle algorithm"
    JOptionPane.showMessageDialog(null, label, title, JOptionPane.PLAIN_MESSAGE)
}


SetAttributes[drawcircle, HoldFirst];
drawcircle[img_, {x0_, y0_}, r_, color_: White] :=
 Module[{f = 1 - r, ddfx = 1, ddfy = -2 r, x = 0, y = r,
   pixels = {{0, r}, {0, -r}, {r, 0}, {-r, 0}}},
  While[x < y,
   If[f >= 0, y--; ddfy += 2; f += ddfy];
   x++; ddfx += 2; f += ddfx;
   pixels = Join[pixels, {{x, y}, {x, -y}, {-x, y}, {-x, -y},
      {y, x}, {y, -x}, {-y, x}, {-y, -x}}]];
  img = ReplacePixelValue[img, {x0, y0} + # -> color & /@ pixels]]


INTERFACE Circle;

IMPORT Bitmap;

PROCEDURE Draw(
  img: Bitmap.T;
  center: Bitmap.Point;
  radius: CARDINAL;
  color: Bitmap.Pixel);

END Circle.


import bitmap

proc setPixel(img: Image; x, y: int; color: Color) {.inline.} =
  # Set a pixel at a given color.
  # Ignore if the point is outside of the image.
  if x in 0..<img.w and y in 0..<img.h:
    img[x, y] = color

proc drawCircle(img: Image; center: Point; radius: Natural; color: Color) =
  ## Draw a circle using midpoint circle algorithm.

  var
    f = 1 - radius
    ddFX = 0
    ddFY = -2 * radius
    x = 0
    y = radius

  img.setPixel(center.x, center.y + radius, color)
  img.setPixel(center.x, center.y - radius, color)
  img.setPixel(center.x + radius, center.y, color)
  img.setPixel(center.x - radius, center.y, color)

  while x < y:
    if f >= 0:
      dec y
      inc ddFY, 2
      inc f, ddFY
    inc x
    inc ddFX, 2
    inc f, ddFX + 1

    img.setPixel(center.x + x, center.y + y, color)
    img.setPixel(center.x - x, center.y + y, color)
    img.setPixel(center.x + x, center.y - y, color)
    img.setPixel(center.x - x, center.y - y, color)
    img.setPixel(center.x + y, center.y + x, color)
    img.setPixel(center.x - y, center.y + x, color)
    img.setPixel(center.x + y, center.y - x, color)
    img.setPixel(center.x - y, center.y - x, color)

#———————————————————————————————————————————————————————————————————————————————————————————————————

when isMainModule:
  var img = newImage(16, 16)
  img.fill(White)
  img.drawCircle((7, 7), 5, Black)
  img.print()


# 20220301 Perl programming solution

use strict;
use warnings;

use Algorithm::Line::Bresenham 'circle';

my @points;
my @circle = circle((10) x 3);

for (@circle) { $points[$_->[0]][$_->[1]] = '#' }

print join "\n", map { join '', map { $_ || ' ' } @$_ } @points


-- demo\rosetta\Bitmap_Circle.exw  (runnable version)
include ppm.e -- red, yellow, new_image(), write_ppm()  -- (covers above requirements)

function SetPx(sequence img, atom x, y, integer colour)
    if  x>=1 and x<=length(img)
    and y>=1 and y<=length(img[x]) then
        img[x][y] = colour
    end if
    return img
end function

function Circle(sequence img, atom x, y, r, integer colour)
    atom x1 = -r,
         y1 = 0,
         err = 2-2*r
    if r>=0 then
        -- Bresenham algorithm
        while 1 do
            img = SetPx(img, x-x1, y+y1, colour)
            img = SetPx(img, x-y1, y-x1, colour)
            img = SetPx(img, x+x1, y-y1, colour)
            img = SetPx(img, x+y1, y+x1, colour)
            r = err
            if r>x1 then
                x1 += 1
                err += x1*2 + 1
            end if
            if r<=y1 then
                y1 += 1
                err += y1*2 + 1
            end if
            if x1>=0 then exit end if
        end while
    end if
    return img
end function

sequence img = new_image(400,300,yellow)
img = Circle(img, 200, 150, 100, red)
write_ppm("Circle.ppm",img)


(de midPtCircle (Img CX CY Rad)
   (let (F (- 1 Rad)  DdFx 0  DdFy (* -2 Rad)  X 0  Y Rad)
      (set (nth Img (+ CY Rad) CX) 1)
      (set (nth Img (- CY Rad) CX) 1)
      (set (nth Img CY (+ CX Rad)) 1)
      (set (nth Img CY (- CX Rad)) 1)
      (while (> Y X)
         (when (ge0 F)
            (dec 'Y)
            (inc 'F (inc 'DdFy 2)) )
         (inc 'X)
         (inc 'F (inc (inc 'DdFx 2)))
         (set (nth Img (+ CY Y) (+ CX X)) 1)
         (set (nth Img (+ CY Y) (- CX X)) 1)
         (set (nth Img (- CY Y) (+ CX X)) 1)
         (set (nth Img (- CY Y) (- CX X)) 1)
         (set (nth Img (+ CY X) (+ CX Y)) 1)
         (set (nth Img (+ CY X) (- CX Y)) 1)
         (set (nth Img (- CY X) (+ CX Y)) 1)
         (set (nth Img (- CY X) (- CX Y)) 1) ) ) )

(let Img (make (do 120 (link (need 120 0))))       # Create image 120 x 120
   (midPtCircle Img 60 60 50)                      # Draw circle
   (out "img.pbm"                                  # Write to bitmap file
      (prinl "P1")
      (prinl 120 " " 120)
      (mapc prinl Img) ) )


/* Plot three circles. */

CIRCLE: PROCEDURE OPTIONS (MAIN);
   declare image (-20:20, -20:20) character (1);
   declare j fixed binary;

   image = '.';
   image(0,*) = '-';
   image(*,0) = '|';
   image(0,0) = '+';

   CALL DRAW_CIRCLE (0, 0, 11);
   CALL DRAW_CIRCLE (0, 0, 8);
   CALL DRAW_CIRCLE (0, 0, 19);

   do j = hbound(image,1) to lbound(image,1) by -1;
      put skip edit (image(j,*)) (a(1));
   end;

draw_circle: procedure (x0, y0, radius);       /* 14 May 2010. */
   declare ( x0, y0, radius ) fixed binary;
   declare ( ddfx, ddfy, x, y, f ) fixed binary;
   declare debug bit (1) aligned static initial ('0'b);

   f    = 1-radius;
   ddfx = 1;
   ddfy = -2*radius;
   x = 0;
   y = radius;
   image(x0, y0+radius) = '*';  /* Octet 0. */
   image(x0+radius, y0) = '*';  /* Octet 1. */
   image(x0, y0-radius) = '*';  /* Octet 2. */
   image(x0-radius, y0) = '*';  /* Octet 3. */

   do while (x < y);
      if f >= 0 then
         do; y = y - 1; ddfy = ddfy +2; f = f + ddfy; end;
      x = x + 1;
      ddfx = ddfx + 2;
      f = f + ddfx;
      image(x0+x, y0+y) = '0';  /* Draws octant 0. */
            image(x0+y, y0+x) = '1';  /* Draws octant 1. */
            image(x0+y, y0-x) = '2';  /* Draws octant 2. */
            image(x0+x, y0-y) = '3';  /* Draws octant 3. */
            image(x0-x, y0-y) = '4';  /* Draws octant 4. */
            image(x0-y, y0-x) = '5';  /* Draws octant 5. */
            image(x0-y, y0+x) = '6';  /* Draws octant 6. */
            image(x0-x, y0+y) = '7';  /* Draws octant 7. */
   end;
end draw_circle;

END CIRCLE;


Procedure rasterCircle(cx, cy, r, Color)
  ;circle must lie completely within the image boundaries
  Protected f= 1 - r
  Protected ddF_X, ddF_Y = -2 * r
  Protected x, y = r

  Plot(cx, cy + r, Color)
  Plot(cx, cy - r, Color)
  Plot(cx + r, cy, Color)
  Plot(cx - r, cy, Color)
  While x < y
    If f >= 0
      y - 1
      ddF_Y + 2
      f + ddF_Y
    EndIf
    x + 1
    ddF_X + 2
    f + ddF_X + 1
    Plot(cx + x, cy + y, Color)
    Plot(cx - x, cy + y, Color)
    Plot(cx + x, cy - y, Color)
    Plot(cx - x, cy - y, Color)
    Plot(cx + y, cy + x, Color)
    Plot(cx - y, cy + x, Color)
    Plot(cx + y, cy - x, Color)
    Plot(cx - y, cy - x, Color)
  Wend
EndProcedure

OpenWindow(0, 0, 0, 100, 100, "MidPoint Circle Algorithm", #PB_Window_SystemMenu)
CreateImage(0, 100, 100, 32)
StartDrawing(ImageOutput(0))
  Box(0, 0, 100, 100, RGB(0, 0, 0))
  rasterCircle(25, 25, 20, RGB(255, 255, 255))
  rasterCircle(50, 50, 40, RGB(255, 0, 0))
StopDrawing()
ImageGadget(0, 0, 0, 0, 0, ImageID(0))

Repeat: Until WaitWindowEvent() = #PB_Event_CloseWindow


def circle(self, x0, y0, radius, colour=black):
    f = 1 - radius
    ddf_x = 1
    ddf_y = -2 * radius
    x = 0
    y = radius
    self.set(x0, y0 + radius, colour)
    self.set(x0, y0 - radius, colour)
    self.set(x0 + radius, y0, colour)
    self.set(x0 - radius, y0, colour)

    while x < y:
        if f >= 0:
            y -= 1
            ddf_y += 2
            f += ddf_y
        x += 1
        ddf_x += 2
        f += ddf_x
        self.set(x0 + x, y0 + y, colour)
        self.set(x0 - x, y0 + y, colour)
        self.set(x0 + x, y0 - y, colour)
        self.set(x0 - x, y0 - y, colour)
        self.set(x0 + y, y0 + x, colour)
        self.set(x0 - y, y0 + x, colour)
        self.set(x0 + y, y0 - x, colour)
        self.set(x0 - y, y0 - x, colour)
Bitmap.circle = circle

bitmap = Bitmap(25,25)
bitmap.circle(x0=12, y0=12, radius=12)
bitmap.chardisplay()

'''
The origin, 0,0; is the lower left, with x increasing to the right,
and Y increasing upwards.

The program above produces the following display :

+-------------------------+
|         @@@@@@@         |
|       @@       @@       |
|     @@           @@     |
|    @               @    |
|   @                 @   |
|  @                   @  |
|  @                   @  |
| @                     @ |
| @                     @ |
|@                       @|
|@                       @|
|@                       @|
|@                       @|
|@                       @|
|@                       @|
|@                       @|
| @                     @ |
| @                     @ |
|  @                   @  |
|  @                   @  |
|   @                 @   |
|    @               @    |
|     @@           @@     |
|       @@       @@       |
|         @@@@@@@         |
+-------------------------+
'''


#lang racket
(require racket/draw)

(define-syntax ⊕ (syntax-rules () [(_ id e) (set! id (+ id e))]))

(define (draw-point dc x y)
  (send dc draw-point x y))

(define (draw-circle dc x0 y0 r)
  (define f (- 1 r))
  (define ddf_x 1)
  (define ddf_y (* -2 r))
  (define x 0)
  (define y r)
  (draw-point dc    x0    (+ y0 r))
  (draw-point dc    x0    (- y0 r))
  (draw-point dc (+ x0 r)    y0)
  (draw-point dc (- x0 r)    y0)
  (let loop ()
    (when (< x y)
      (when (>= f 0)
        (⊕ y -1)
        (⊕ ddf_y 2)
        (⊕ f ddf_y))
      (⊕ x 1)
      (⊕ ddf_x 2)
      (⊕ f ddf_x)
      (draw-point dc (+ x0 x) (+ y0 y))
      (draw-point dc (- x0 x) (+ y0 y))
      (draw-point dc (+ x0 x) (- y0 y))
      (draw-point dc (- x0 x) (- y0 y))
      (draw-point dc (+ x0 y) (+ y0 x))
      (draw-point dc (- x0 y) (+ y0 x))
      (draw-point dc (+ x0 y) (- y0 x))
      (draw-point dc (- x0 y) (- y0 x))
      (loop))))

(define bm (make-object bitmap% 25 25))
(define dc (new bitmap-dc% [bitmap bm]))
(send dc set-smoothing 'unsmoothed)
(send dc set-pen "red" 1 'solid)
(draw-circle dc 12 12 12)
bm


use MONKEY-TYPING;

class Pixel { has UInt ($.R, $.G, $.B) }
class Bitmap {
    has UInt ($.width, $.height);
    has Pixel @!data;

    method fill(Pixel \p) {
        @!data = p xx ($!width × $!height)
    }

    method pixel( \i where ^$!width, \j where ^$!height --> Pixel) is rw {
        @!data[i × $!width + j]
    }

    method set-pixel (\i, \j, Pixel \p) {
        self.pixel(i, j) = p;
    }

    method get-pixel (\i, \j) returns Pixel {
        self.pixel(i, j);
    }
}

augment class Pixel  { method Str { "$.R $.G $.B" } }
augment class Bitmap {
    method P3 {
        join "\n", «P3 "$.width $.height" 255»,
        do for ^($.width × $.height) { join ' ', @!data[$_] }
    }

    method raster-circle ( \x0, \y0, \r, Pixel \value ) {
        my $ddF_x   =  0;
        my $ddF_y   = -2 × r;
        my $f       =  1 - r;
        my ($x, $y) =  0,  r;
        for flat (0 X 1,-1),(1,-1 X 0) -> \i, \j {
            self.set-pixel(x0 + i×r, y0 + j×r, value)
        }

        while $x < $y {
            ($y--; $f +=     ($ddF_y += 2)) if $f ≥ 0;
             $x++; $f += 1 + ($ddF_x += 2);
            for flat (1,-1) X (1,-1) -> \i, \j {
                self.set-pixel(x0 + i×$x, y0 + j×$y, value);
                self.set-pixel(x0 + i×$y, y0 + j×$x, value);
            }
        }
    }
}

my Bitmap $b = Bitmap.new( width => 32, height => 32);
$b.fill( Pixel.new( R => 0, G => 0, B => 0) );
$b.raster-circle(16, 16, 15, Pixel.new(R=>0, G=>0, B=>100));
say $b.P3;


let raster_circle ~img ~color ~c:(x0, y0) ~r =
  let plot = put_pixel img color in
  let x = 0
  and y = r
  and m = 5 - 4 * r
  in
  let rec loop x y m =
    plot (x0 + x) (y0 + y);
    plot (x0 + y) (y0 + x);
    plot (x0 - x) (y0 + y);
    plot (x0 - y) (y0 + x);
    plot (x0 + x) (y0 - y);
    plot (x0 + y) (y0 - x);
    plot (x0 - x) (y0 - y);
    plot (x0 - y) (y0 - x);
    let y, m =
      if m > 0
      then (y - 1), (m - 8 * y)
      else y, m
    in
    if x <= y then
      let x = x + 1 in
      let m = m + 8 * x + 4 in
      loop x y m
  in
  loop x y m
;;


/*REXX program  plots  three circles  using  midpoint/Bresenham's circle algorithm.     */
@.= '·'                                          /*fill the array with middle─dots char.*/
minX= 0;    maxX= 0;     minY= 0;     maxY= 0    /*initialize the minimums and maximums.*/
call drawCircle   0,   0,   8,   '#'             /*plot 1st circle with pound character.*/
call drawCircle   0,   0,  11,   '$'             /*  "  2nd    "     "  dollar    "     */
call drawCircle   0,   0,  19,   '@'             /*  "  3rd    "     "  commercial at.  */
border= 2                                        /*BORDER:  shows  N  extra grid points.*/
minX= minX - border*2;    maxX= maxX + border*2  /*adjust min and max  X  to show border*/
minY= minY - border  ;    maxY= maxY + border    /*   "    "   "   "   Y   "   "     "  */
if @.0.[email protected].  then @.0.0= '┼'                    /*maybe define the plot's axis origin. */
                                                 /*define the plot's horizontal grid──┐ */
  do h=minX  to maxX;  if @.h.[email protected].  then @.h.0= '─';  end             /* ◄───────────┘ */
  do v=minY  to maxY;  if @.0.[email protected].  then @.0.v= '│';  end             /* ◄──────────┐  */
                                                 /*define the plot's vertical grid───┘  */
     do y=maxY  by -1  to minY;   _=             /* [↓]  draw grid from  top ──► bottom.*/
             do x=minX  to maxX;  _= _ || @.x.y  /* ◄───   "    "    "  left ──► right. */
             end   /*x*/                         /* [↑]  a grid row should be finished. */
     say _                                       /*display a single row of the grid.    */
     end           /*y*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
drawCircle: procedure expose @. minX maxX minY maxY
            parse arg xx,yy,r 1 y,plotChar;     fx= 1;    fy= -2*r /*get X,Y coördinates*/
            f= 1 - r
                     do x=0  while  x<y  /*▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒*/
                     if f>=0  then  do;  y= y - 1;   fy= fy + 2;   f= f + fy;   end  /*▒*/
                                                     fx= fx + 2;   f= f + fx         /*▒*/
                     call plotPoint  xx+x,  yy+y                                     /*▒*/
                     call plotPoint  xx+y,  yy+x                                     /*▒*/
                     call plotPoint  xx+y,  yy-x                                     /*▒*/
                     call plotPoint  xx+x,  yy-y                                     /*▒*/
                     call plotPoint  xx-y,  yy+x                                     /*▒*/
                     call plotPoint  xx-x,  yy+y                                     /*▒*/
                     call plotPoint  xx-x,  yy-y                                     /*▒*/
                     call plotPoint  xx-y,  yy-x                                     /*▒*/
                     end   /*x*/         /* [↑]  place plot points ══► plot.▒▒▒▒▒▒▒▒▒▒▒▒*/
            return
/*──────────────────────────────────────────────────────────────────────────────────────*/
plotPoint: parse arg c,r;      @.c.r= plotChar   /*assign a character to be plotted.    */
           minX= min(minX,c);  maxX= max(maxX,c) /*determine the minimum and maximum  X.*/
           minY= min(minY,r);  maxY= max(maxY,r) /*    "      "     "     "     "     Y.*/
           return


Pixel = Struct.new(:x, :y)

class Pixmap
  def draw_circle(pixel, radius, colour)
    validate_pixel(pixel.x, pixel.y)

    self[pixel.x, pixel.y + radius] = colour
    self[pixel.x, pixel.y - radius] = colour
    self[pixel.x + radius, pixel.y] = colour
    self[pixel.x - radius, pixel.y] = colour

    f = 1 - radius
    ddF_x = 1
    ddF_y = -2 * radius
    x = 0
    y = radius
    while x < y
      if f >= 0
        y -= 1
        ddF_y += 2
        f += ddF_y
      end
      x += 1
      ddF_x += 2
      f += ddF_x
      self[pixel.x + x, pixel.y + y] = colour
      self[pixel.x + x, pixel.y - y] = colour
      self[pixel.x - x, pixel.y + y] = colour
      self[pixel.x - x, pixel.y - y] = colour
      self[pixel.x + y, pixel.y + x] = colour
      self[pixel.x + y, pixel.y - x] = colour
      self[pixel.x - y, pixel.y + x] = colour
      self[pixel.x - y, pixel.y - x] = colour
    end
  end
end

bitmap = Pixmap.new(30, 30)
bitmap.draw_circle(Pixel[14,14], 12, RGBColour::BLACK)


object BitmapOps {
   def midpoint(bm:RgbBitmap, x0:Int, y0:Int, radius:Int, c:Color)={
      var f=1-radius
      var ddF_x=1
      var ddF_y= -2*radius
      var x=0
      var y=radius

      bm.setPixel(x0, y0+radius, c)
      bm.setPixel(x0, y0-radius, c)
      bm.setPixel(x0+radius, y0, c)
      bm.setPixel(x0-radius, y0, c)

      while(x < y)
      {
         if(f >= 0)
         {
           y-=1
           ddF_y+=2
           f+=ddF_y
         }
         x+=1
         ddF_x+=2
         f+=ddF_x

         bm.setPixel(x0+x, y0+y, c)
         bm.setPixel(x0-x, y0+y, c)
         bm.setPixel(x0+x, y0-y, c)
         bm.setPixel(x0-x, y0-y, c)
         bm.setPixel(x0+y, y0+x, c)
         bm.setPixel(x0-y, y0+x, c)
         bm.setPixel(x0+y, y0-x, c)
         bm.setPixel(x0-y, y0-x, c)
      }
   }
}


package require Tcl 8.5
package require Tk

proc drawCircle {image colour point radius} {
    lassign $point x0 y0

    setPixel $image $colour [list $x0 [expr {$y0 + $radius}]]
    setPixel $image $colour [list $x0 [expr {$y0 - $radius}]]
    setPixel $image $colour [list [expr {$x0 + $radius}] $y0]
    setPixel $image $colour [list [expr {$x0 - $radius}] $y0]

    set f [expr {1 - $radius}]
    set ddF_x 1
    set ddF_y [expr {-2 * $radius}]
    set x 0
    set y $radius

    while {$x < $y} {
        assert {$ddF_x == 2 * $x + 1}
        assert {$ddF_y == -2 * $y}
        assert {$f == $x*$x + $y*$y - $radius*$radius + 2*$x - $y + 1}
        if {$f >= 0} {
            incr y -1
            incr ddF_y 2
            incr f $ddF_y
        }
        incr x
        incr ddF_x 2
        incr f $ddF_x
        setPixel $image $colour [list [expr {$x0 + $x}] [expr {$y0 + $y}]]
        setPixel $image $colour [list [expr {$x0 - $x}] [expr {$y0 + $y}]]
        setPixel $image $colour [list [expr {$x0 + $x}] [expr {$y0 - $y}]]
        setPixel $image $colour [list [expr {$x0 - $x}] [expr {$y0 - $y}]]
        setPixel $image $colour [list [expr {$x0 + $y}] [expr {$y0 + $x}]]
        setPixel $image $colour [list [expr {$x0 - $y}] [expr {$y0 + $x}]]
        setPixel $image $colour [list [expr {$x0 + $y}] [expr {$y0 - $x}]]
        setPixel $image $colour [list [expr {$x0 - $y}] [expr {$y0 - $x}]]

    }
}

# create the image and display it
set img [newImage 200 100]
label .l -image $img
pack .l

fill $img black
drawCircle $img blue {100 50} 49


import "graphics" for Canvas, Color, ImageData
import "dome" for Window

class MidpointCircle {
    construct new(width, height) {
        Window.title = "Midpoint Circle"
        Window.resize(width, height)
        Canvas.resize(width, height)
        _w = width
        _h = height
        _bmp = ImageData.create("midpoint circle", width, height)
    }

    init() {
        fill(Color.pink)
        drawCircle(200, 200, 100, Color.black)
        drawCircle(200, 200,  50, Color.white)
        _bmp.draw(0, 0)
    }

    fill(col) {
        for (x in 0..._w) {
            for (y in 0..._h) pset(x, y, col)
        }
    }

    drawCircle(centerX, centerY, radius, circleColor) {
        var d = ((5 - radius * 4)/4).truncate
        var x = 0
        var y = radius
        while (true) {
            pset(centerX + x, centerY + y, circleColor)
            pset(centerX + x, centerY - y, circleColor)
            pset(centerX - x, centerY + y, circleColor)
            pset(centerX - x, centerY - y, circleColor)
            pset(centerX + y, centerY + x, circleColor)
            pset(centerX + y, centerY - x, circleColor)
            pset(centerX - y, centerY + x, circleColor)
            pset(centerX - y, centerY - x, circleColor)
            if (d < 0) {
                d = d + 2 * x + 1
            } else {
                d = d + 2 * (x - y) + 1
                y = y - 1
            }
            x = x + 1
            if (x > y) break
        }
    }

    pset(x, y, col) { _bmp.pset(x, y, col) }

    pget(x, y) { _bmp.pget(x, y) }

    update() {}

    draw(alpha) {}
}

var Game = MidpointCircle.new(400, 400)


V x = 10
V y = 2
print(‘x       = ’x)
print(‘y       = ’y)
print(‘NOT x   = ’(-)x)
print(‘x AND y = ’(x [&] y))
print(‘x OR  y = ’(x [|] y))
print(‘x XOR y = ’(x (+) y))
print(‘x SHL y = ’(x << y))
print(‘x SHR y = ’(x >> y))
print(‘x ROL y = ’rotl(x, y))
print(‘x ROR y = ’rotr(x, y))


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

proc Circle(X0, Y0, Radius, Color);     \Display a circle
int  X0, Y0,    \coordinates of center
     Radius,    \radius in (pixels)
     Color;     \line color
int  X, Y, E, U, V;

        proc PlotOctants;               \Segment
        [Point(X0+Y, Y0+X, Color);      \ 0
        Point(X0+X, Y0+Y, Color);       \ 1
        Point(X0-X, Y0+Y, Color);       \ 2
        Point(X0-Y, Y0+X, Color);       \ 3
        Point(X0-Y, Y0-X, Color);       \ 4
        Point(X0-X, Y0-Y, Color);       \ 5
        Point(X0+X, Y0-Y, Color);       \ 6
        Point(X0+Y, Y0-X, Color);       \ 7
        ]; \PlotOctants

[X:= 0;  Y:= Radius;
U:= 1;
V:= 1 -Radius -Radius;
E:= 1 -Radius;
while X < Y do
        [PlotOctants;
        if E < 0 then
                [U:= U+2;  V:= V+2;  E:= E+U]
        else    [U:= U+2;  V:= V+4;  E:= E+V;  Y:= Y-1];
        X:= X+1;
        ];
if X = Y then PlotOctants;
]; \Circle

[SetVid($112);          \640x480 in 24-bit RGB color
Circle(110, 110, 50, $FFFF00);
if ChIn(1) then [];     \wait for keystroke
SetVid(3);              \restore normal text mode
]


   fcn circle(x0,y0,r,rgb){
      x:=r; y:=0; radiusError:=1-x;
      while(x >= y){
         __sSet(rgb, x + x0,  y + y0);
	 __sSet(rgb, y + x0,  x + y0);
	 __sSet(rgb,-x + x0,  y + y0);
	 __sSet(rgb,-y + x0,  x + y0);
	 self[-x + x0, -y + y0]=rgb;	// or do it this way, __sSet gets called as above
	 self[-y + x0, -x + y0]=rgb;
	 self[ x + x0, -y + y0]=rgb;
	 self[ y + x0, -x + y0]=rgb;
	 y+=1;
	 if (radiusError<0) radiusError+=2*y + 1;
	 else{ x-=1; radiusError+=2*(y - x + 1); }
      }
   }


*        Bitwise operations        15/02/2017
BITWISE  CSECT
         USING  BITWISE,R13
         B      72(R15)
         DC     17F'0'
         STM    R14,R12,12(R13)
         ST     R13,4(R15)
         ST     R15,8(R13)
         LR     R13,R15
         L      R1,A
         XDECO  R1,PG
         MVC    OP,=CL7'A='
         XPRNT  OP,L'OP+L'PG
         L      R1,B
         XDECO  R1,PG
         MVC    OP,=CL7'B='
         XPRNT  OP,L'OP+L'PG
*                                  And
         L      R1,A
         N      R1,B
         XDECO  R1,PG
         MVC    OP,=C'A AND B'
         XPRNT  OP,L'OP+L'PG
*                                  Or
         L      R1,A
         O      R1,B
         XDECO  R1,PG
         MVC    OP,=C'A OR  B'
         XPRNT  OP,L'OP+L'PG
*                                  Xor
         L      R1,A
         X      R1,B
         XDECO  R1,PG
         MVC    OP,=C'A XOR B'
         XPRNT  OP,L'OP+L'PG
*                                  Not
         L      R1,A
         X      R1,=X'FFFFFFFF'    not (by xor -1)
         XDECO  R1,PG
         MVC    OP,=CL7'NOT A'
         XPRNT  OP,L'OP+L'PG
*
         MVC    A,=X'80000008'     a=-2147483640 (-2^31+8)
         L      R1,A
         XDECO  R1,PG
         MVC    OP,=CL7'A='
         XPRNT  OP,L'OP+L'PG
*                                  shift right arithmetic (on 31 bits)
         L      R1,A
         SRA    R1,3
         XDECO  R1,PG
         MVC    OP,=C'A SRA 3'
         XPRNT  OP,L'OP+L'PG
*                                  shift left arithmetic (on 31 bits)
         L      R1,A
         SLA    R1,3
         XDECO  R1,PG
         MVC    OP,=C'A SLA 3'
         XPRNT  OP,L'OP+L'PG
*                                  shift right logical (on 32 bits)
         L      R1,A
         SRL    R1,3
         XDECO  R1,PG
         MVC    OP,=C'A SRL 3'
         XPRNT  OP,L'OP+L'PG
*                                  shift left logical (on 32 bits)
         L      R1,A
         SLL    R1,3
         XDECO  R1,PG
         MVC    OP,=C'A SLL 3'
         XPRNT  OP,L'OP+L'PG
*
RETURN   L      R13,4(0,R13)
         LM     R14,R12,12(R13)
         XR     R15,R15
         BR     R14
A        DC     F'21'
B        DC     F'3'
OP       DS     CL7
PG       DS     CL12
         YREGS
         END    BITWISE


LDA #$05
STA temp ;temp equals 5 for the following


; bitwise AND
anl a, b

; bitwise OR
orl a, b

; bitwise XOR
xrl a, b

; bitwise NOT
cpl a

; left shift
inc b
rrc a
loop:
rlc a
clr c
djnz b, loop

; right shift
inc b
rlc a
loop:
rrc a
clr c
djnz b, loop

; arithmetic right shift
push 20
inc b
rlc a
mov 20.0, c
loop:
rrc a
mov c, 20.0
djnz b, loop
pop 20

; left rotate
inc b
rr a
loop:
rl a
djnz b, loop

; right rotate
inc b
rl a
loop:
rr a
djnz b, loop


report z_bitwise_operations.

class hex_converter definition.
  public section.
    class-methods:
      to_binary
        importing
          hex_value           type x
        returning
          value(binary_value) type string,

      to_decimal
        importing
          hex_value            type x
        returning
          value(decimal_value) type int4.
endclass.

class hex_converter implementation.
  method to_binary.
    data(number_of_bits) = xstrlen( hex_value ) * 8.

    do number_of_bits times.
      get bit sy-index of hex_value into data(bit).

      binary_value = |{ binary_value }{ bit }|.
    enddo.
  endmethod.

  method to_decimal.
    decimal_value = hex_value.
  endmethod.
endclass.

class missing_bitwise_operations definition.
  public section.
    class-methods:
      arithmetic_shift_left
        importing
          old_value   type x
          change_with type x
        exporting
          new_value   type x,

      arithmetic_shift_right
        importing
          old_value   type x
          change_with type x
        exporting
          new_value   type x,

      logical_shift_left
        importing
          old_value   type x
          change_with type x
        exporting
          new_value   type x,

      logical_shift_right
        importing
          old_value   type x
          change_with type x
        exporting
          new_value   type x,

      rotate_left
        importing
          old_value   type x
          change_with type x
        exporting
          new_value   type x,

      rotate_right
        importing
          old_value   type x
          change_with type x
        exporting
          new_value   type x.
endclass.

class missing_bitwise_operations implementation.
  method arithmetic_shift_left.
    clear new_value.

    new_value = old_value * 2 ** change_with.
  endmethod.

  method arithmetic_shift_right.
    clear new_value.

    new_value = old_value div 2 ** change_with.
  endmethod.

  method logical_shift_left.
    clear new_value.

    data(bits) = hex_converter=>to_binary( old_value ).

    data(length_of_bit_sequence) = strlen( bits ).

    bits = shift_left(
      val = bits
      places = change_with ).

    while strlen( bits ) < length_of_bit_sequence.
      bits = |{ bits }0|.
    endwhile.

    do strlen( bits ) times.
      data(index) = sy-index - 1.

      data(current_bit) = bits+index(1).

      if current_bit eq `1`.
        set bit sy-index of new_value.
      endif.
    enddo.
  endmethod.

  method logical_shift_right.
    clear new_value.

    data(bits) = hex_converter=>to_binary( old_value ).

    data(length_of_bit_sequence) = strlen( bits ).

    bits = shift_right(
      val = bits
      places = change_with ).

    while strlen( bits ) < length_of_bit_sequence.
      bits = |0{ bits }|.
    endwhile.

    do strlen( bits ) times.
      data(index) = sy-index - 1.

      data(current_bit) = bits+index(1).

      if current_bit eq `1`.
        set bit sy-index of new_value.
      endif.
    enddo.
  endmethod.

  method rotate_left.
    clear new_value.

    data(bits) = hex_converter=>to_binary( old_value ).

    bits = shift_left(
      val = bits
      circular = change_with ).

    do strlen( bits ) times.
      data(index) = sy-index - 1.

      data(current_bit) = bits+index(1).

      if current_bit eq `1`.
        set bit sy-index of new_value.
      endif.
    enddo.
  endmethod.

  method rotate_right.
    clear new_value.

    data(bits) = hex_converter=>to_binary( old_value ).

    bits = shift_right(
      val = bits
      circular = change_with ).

    do strlen( bits ) times.
      data(index) = sy-index - 1.

      data(current_bit) = bits+index(1).

      if current_bit eq `1`.
        set bit sy-index of new_value.
      endif.
    enddo.
  endmethod.
endclass.

start-of-selection.
  data:
    a      type x length 4 value 255,
    b      type x length 4 value 2,
    result type x length 4.

  write: |a         -> { a }, { hex_converter=>to_binary( a ) }, { hex_converter=>to_decimal( a ) }|, /.

  write: |b         -> { b }, { hex_converter=>to_binary( b ) }, { hex_converter=>to_decimal( b ) }|, /.

  result = a bit-and b.
  write: |a & b     -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  result = a bit-or b.
  write: |a \| b     -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  result = a bit-xor b.
  write: |a ^ b     -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  result = bit-not a.
  write: |~a        -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  missing_bitwise_operations=>arithmetic_shift_left(
    exporting
      old_value = bit-not a
      change_with = b
    importing
      new_value = result ).
  write: |~a << b   -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  missing_bitwise_operations=>arithmetic_shift_right(
    exporting
      old_value = bit-not a
      change_with = b
    importing
      new_value = result ).
  write: |~a >> b   -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  missing_bitwise_operations=>logical_shift_left(
    exporting
      old_value = a
      change_with = b
    importing
      new_value = result ).
  write: |a <<< b   -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  missing_bitwise_operations=>logical_shift_right(
    exporting
      old_value = bit-not a
      change_with = b
    importing
      new_value = result ).
  write: |~a >>> b  -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  missing_bitwise_operations=>rotate_left(
    exporting
      old_value = bit-not a
      change_with = b
    importing
      new_value = result ).
  write: |~a rotl b -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.

  missing_bitwise_operations=>rotate_right(
    exporting
      old_value = a
      change_with = b
    importing
      new_value = result ).
  write: |a rotr b  -> { result }, { hex_converter=>to_binary( result ) }, { hex_converter=>to_decimal( result ) }|, /.


(defun bitwise (a b)
   (list (logand a b)
         (logior a b)
         (logxor a b)
         (lognot a)
         (ash a b)
         (ash a (- b))))


BYTE FUNC Not(BYTE a)
RETURN (a!$FF)

PROC Main()
  BYTE a=[127],b=[2],res

  res=a&b
  PrintF("%B AND %B = %B%E",a,b,res)

  res=a%b
  PrintF("%B OR %B = %B%E",a,b,res)

  res=a!b
  PrintF("%B XOR %B = %B%E",a,b,res)

  res=Not(a)
  PrintF("NOT %B = %B (by %B XOR $FF)%E",a,res,a)

  res=a RSH b
  PrintF("%B SHR %B = %B%E",a,b,res)

  res=a LSH b
  PrintF("%B SHL %B = %B%E",a,b,res)
RETURN


function bitwise(a:int, b:int):void
{
	trace("And: ", a & b);
	trace("Or: ", a | b);
	trace("Xor: ", a ^ b);
	trace("Not: ", ~a);
	trace("Left Shift: ", a << b);
	trace("Right Shift(Arithmetic): ", a >> b);
	trace("Right Shift(Logical): ", a >>> b);
}


with Ada.Text_IO, Interfaces;
use  Ada.Text_IO, Interfaces;

procedure Bitwise is
   subtype Byte is Unsigned_8;
   package Byte_IO is new Ada.Text_Io.Modular_IO (Byte);

   A : constant Byte    := 2#00011110#;
   B : constant Byte    := 2#11110100#;
   X : constant Byte    := 128;
   N : constant Natural := 1;
begin
   Put ("A and B = ");  Byte_IO.Put (Item => A and B, Base => 2);  New_Line;
   Put ("A or B  = ");  Byte_IO.Put (Item => A or B,  Base => 2);  New_Line;
   Put ("A xor B = ");  Byte_IO.Put (Item => A xor B, Base => 2);  New_Line;
   Put ("not A   = ");  Byte_IO.Put (Item => not A,   Base => 2);  New_Line;
   New_Line (2);
   Put_Line (Unsigned_8'Image (Shift_Left  (X, N)));
   Put_Line (Unsigned_8'Image (Shift_Right (X, N)));
   Put_Line (Unsigned_8'Image (Shift_Right_Arithmetic (X, N)));
   Put_Line (Unsigned_8'Image (Rotate_Left  (X, N)));
   Put_Line (Unsigned_8'Image (Rotate_Right (X, N)));
end Bitwise;


function bitwise(a, b){
   println("a AND b: " + (a & b))
   println("a OR b: "+ (a | b))
   println("a XOR b: "+ (a ^ b))
   println("NOT a: " + ~a)
   println("a << b: " + (a << b)) // left shift
   println("a >> b: " + (a >> b)) // arithmetic right shift
   println("a >>> b: " + (a >>> b)) // logical right shift
}


main:(

  PRIO SLC = 8, SRC = 8; # SLC and SRC are not built in, define and overload them here #
  OP SLC = (BITS b, INT rotate) BITS: b SHL rotate OR b SHR ( bits width - rotate );
  OP SRC = (BITS b, INT rotate) BITS: b SHR rotate OR b SHL ( bits width - rotate );
  # SRC and SRL are non-standard, but versions are built in to ALGOL 68R's standard prelude #

  PRIO XOR = 2;
  OP XOR = (BITS p, q) BITS: p AND NOT q OR NOT p AND q;
  # XOR is non-standard, but a version is built in to ALGOL 68G's standard prelude #

  # ALGOL 68 has 5 different ways of representing a BINary BITS - Bases: 2, 4, 8, 16 and flip/flop #
  FORMAT b5 = $"2r"2r32d," 4r"4r16d," 8r"8r11d," 16r"16r8d," "gl$;
  OP BBBBB = (BITS b)[]BITS: (b,b,b,b,b);

  PROC bitwise = (BITS a, BITS b, INT shift)VOID:
  (
    printf((
      $"         bits shorths: "gxgl$, bits shorths, "1 plus the number of extra SHORT BITS types",
      $"         bits lengths: "gxgl$, bits lengths, "1 plus the number of extra LONG BITS types",
      $"             max bits: "gl$, max bits,
      $"        long max bits: "gl$, long max bits,
      $"   long long max bits: "gl$, long long max bits,
      $"           bits width: "gxgl$, bits width, "The number of CHAR required to display BITS",
      $"      long bits width: "gxgl$, long bits width, "The number of CHAR required to display LONG BITS",
      $" long long bits width: "gxgl$, long long bits width, "The number of CHAR required to display LONG LONG BITS",
      $"         bytes shorths: "gxgl$, bytes shorths, "1 plus the number of extra SHORT BYTES types",
      $"         bytes lengths: "gxgl$, bits lengths, "1 plus the number of extra LONG BYTES types",
      $"          bytes width: "gxgl$, bytes width, "The number of CHAR required to display BYTES",
      $"     long bytes width: "gxgl$, long bytes width, "The number of CHAR required to display LONG BYTES"
    ));

    printf(($" a:       "f(b5)$, BBBBB a));
    printf(($" b:       "f(b5)$, BBBBB b));
    printf(($" a AND b: "f(b5)$, BBBBB(a AND b)));
    printf(($" a OR b:  "f(b5)$, BBBBB(a OR b)));
    printf(($" a XOR b: "f(b5)$, BBBBB(a XOR b)));
    printf(($" NOT b:   "f(b5)$, BBBBB NOT a));
    printf(($" a SHL "d": "f(b5)$, shift, BBBBB(a SHL shift)));
    printf(($" a SHR "d": "f(b5)$, shift, BBBBB(a SHR shift)));

    printf(($" a SLC "d": "f(b5)$, shift, BBBBB(a SLC shift)));
    printf(($" a SRC "d": "f(b5)$, shift, BBBBB(a SRC shift)))
COMMENT with original ALGOL 68 character set;
    printf(($" a AND b: "f(b5)$, BBBBB(a ∧ b)));
    printf(($" a OR b:  "f(b5)$, BBBBB(a ∨ b)));
    printf(($" NOT b:   "f(b5)$, BBBBB ¬ a));
    printf(($" a SHL "d": "f(b5)$, shift, BBBBB(a ↑ shift)));
    printf(($" a SHR "d": "f(b5)$, shift, BBBBB(a ↓ shift)));
Also:
    printf(($" a AND b: "f(b5)$, BBBBB(a /\ b)));
    printf(($" a OR b: "f(b5)$, BBBBB(a \/ b)));
COMMENT
  );

  bitwise(BIN 255, BIN 170, 5)
# or using alternate representations for 255 and 170 in BITS #
CO
  bitwise(2r11111111,2r10101010,5);
  bitwise(4r3333,4r2222,5);
  bitwise(8r377,8r252,5);
  bitwise(16rff,16raa,5)
END CO
)


% performs bitwise and, or, not, left-shift and right shift on the integers n1 and n2 %
% Algol W does not have xor, arithmetic right shift, left rotate or right rotate      %
procedure bitOperations ( integer value n1, n2 ) ;
begin
    bits b1, b2;
    % the Algol W bitwse operations operate on bits values, so we first convert the   %
    % integers to bits values using the builtin bitstring procedure                   %
    % the results are converted back to integers using the builtin number procedure   %
    % all Algol W bits and integers are 32 bits quantities                            %
    b1 := bitstring( n1 );
    b2 := bitstring( n2 );
    % perform the operaations and display the results as integers                     %
    write( n1, " and ", n2, " = ", number( b1 and b2 ) );
    write( n1, " or  ", n2, " = ", number( b1 or  b2 ) );
    write( "                "
         ,     " not ", n1, " = ", number(    not b1 ) );
    write( n1, " shl ", n2, " = ", number( b1 shl n2 ), " (  left-shift )"  );
    write( n1, " shr ", n2, " = ", number( b1 shr n2 ), " ( right-shift )"  )
end bitOPerations ;


use AppleScript version "2.4"
use framework "Foundation"
use scripting additions

-- BIT OPERATIONS FOR APPLESCRIPT (VIA JAVASCRIPT FOR AUTOMATION)

-- bitAND :: Int -> Int -> Int
on bitAND(x, y)
    jsOp2("&", x, y)
end bitAND

-- bitOR :: Int -> Int -> Int
on bitOR(x, y)
    jsOp2("|", x, y)
end bitOR

-- bitXOr :: Int -> Int -> Int
on bitXOR(x, y)
    jsOp2("^", x, y)
end bitXOR

-- bitNOT :: Int -> Int
on bitNOT(x)
    jsOp1("~", x)
end bitNOT

-- (<<) :: Int -> Int -> Int
on |<<|(x, y)
    if 31 < y then
        0
    else
        jsOp2("<<", x, y)
    end if
end |<<|

-- Logical right shift
-- (>>>) :: Int -> Int -> Int
on |>>>|(x, y)
    jsOp2(">>>", x, y)
end |>>>|

-- Arithmetic right shift
-- (>>) :: Int -> Int -> Int
on |>>|(x, y)
    jsOp2(">>", x, y)
end |>>|

-- TEST ----------------------------------------------------------
on run
    -- Using an ObjC interface to Javascript for Automation

    set strClip to bitWise(255, 170)
    set the clipboard to strClip
    strClip
end run

-- bitWise :: Int -> Int -> String
on bitWise(a, b)
    set labels to {"a AND b", "a OR b", "a XOR b", "NOT a", ¬
        "a << b", "a >>> b", "a >> b"}
    set xs to {bitAND(a, b), bitOR(a, b), bitXOR(a, b), bitNOT(a), ¬
        |<<|(a, b), |>>>|(a, b), |>>|(a, b)}

    script asBin
        property arrow : " -> "
        on |λ|(x, y)
            justifyRight(8, space, x) & arrow & ¬
                justifyRight(14, space, y as text) & arrow & showBinary(y)
        end |λ|
    end script

    unlines({"32 bit signed integers   (in two's complement binary encoding)", "", ¬
        unlines(zipWith(asBin, ¬
            {"a = " & a as text, "b = " & b as text}, {a, b})), "", ¬
        unlines(zipWith(asBin, labels, xs))})
end bitWise

-- CONVERSIONS AND DISPLAY

-- bitsFromInt :: Int -> Either String [Bool]
on bitsFromIntLR(x)
    script go
        on |λ|(n, d, bools)
            set xs to {0 ≠ d} & bools
            if n > 0 then
                |λ|(n div 2, n mod 2, xs)
            else
                xs
            end if
        end |λ|
    end script

    set a to abs(x)
    if (2.147483647E+9) < a then
        |Left|("Integer overflow – maximum is (2 ^ 31) - 1")
    else
        set bs to go's |λ|(a div 2, a mod 2, {})
        if 0 > x then
            |Right|(replicate(32 - (length of bs), true) & ¬
                binSucc(map(my |not|, bs)))
        else
            set bs to go's |λ|(a div 2, a mod 2, {})
            |Right|(replicate(32 - (length of bs), false) & bs)
        end if
    end if
end bitsFromIntLR

-- Successor function (+1) for unsigned binary integer

-- binSucc :: [Bool] -> [Bool]
on binSucc(bs)
    script succ
        on |λ|(a, x)
            if a then
                if x then
                    Tuple(a, false)
                else
                    Tuple(x, true)
                end if
            else
                Tuple(a, x)
            end if
        end |λ|
    end script

    set tpl to mapAccumR(succ, true, bs)
    if |1| of tpl then
        {true} & |2| of tpl
    else
        |2| of tpl
    end if
end binSucc

-- showBinary :: Int -> String
on showBinary(x)
    script showBin
        on |λ|(xs)
            script bChar
                on |λ|(b)
                    if b then
                        "1"
                    else
                        "0"
                    end if
                end |λ|
            end script

            map(bChar, xs)
        end |λ|
    end script
    bindLR(my bitsFromIntLR(x), showBin)
end showBinary

-- JXA ------------------------------------------------------------------

--jsOp2 :: String -> a -> b -> c
on jsOp2(strOp, a, b)
    bindLR(evalJSLR(unwords({a as text, strOp, b as text})), my |id|) as integer
end jsOp2

--jsOp2 :: String -> a -> b
on jsOp1(strOp, a)
    bindLR(evalJSLR(unwords({strOp, a as text})), my |id|) as integer
end jsOp1

-- evalJSLR :: String -> Either String a
on evalJSLR(strJS)
    try -- NB if gJSC is global it must be released
        -- (e.g. set to null) at end of script
        gJSC's evaluateScript
    on error
        set gJSC to current application's JSContext's new()
        log ("new JSC")
    end try
    set v to unwrap((gJSC's evaluateScript:(strJS))'s toObject())
    if v is missing value then
        |Left|("JS evaluation error")
    else
        |Right|(v)
    end if
end evalJSLR

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

-- Left :: a -> Either a b
on |Left|(x)
    {type:"Either", |Left|:x, |Right|:missing value}
end |Left|

-- Right :: b -> Either a b
on |Right|(x)
    {type:"Either", |Left|:missing value, |Right|:x}
end |Right|

-- Tuple (,) :: a -> b -> (a, b)
on Tuple(a, b)
    {type:"Tuple", |1|:a, |2|:b, length:2}
end Tuple

-- Absolute value.
-- abs :: Num -> Num
on abs(x)
    if 0 > x then
        -x
    else
        x
    end if
end abs

-- bindLR (>>=) :: Either a -> (a -> Either b) -> Either b
on bindLR(m, mf)
    if missing value is not |Right| of m then
        mReturn(mf)'s |λ|(|Right| of m)
    else
        m
    end if
end bindLR

-- foldr :: (a -> b -> b) -> b -> [a] -> b
on foldr(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from lng to 1 by -1
            set v to |λ|(item i of xs, v, i, xs)
        end repeat
        return v
    end tell
end foldr

-- id :: a -> a
on |id|(x)
    x
end |id|

-- justifyRight :: Int -> Char -> String -> String
on justifyRight(n, cFiller, strText)
    if n > length of strText then
        text -n thru -1 of ((replicate(n, cFiller) as text) & strText)
    else
        strText
    end if
end justifyRight

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- 'The mapAccumR function behaves like a combination of map and foldr;
--  it applies a function to each element of a list, passing an accumulating
--  parameter from |Right| to |Left|, and returning a final value of this
--  accumulator together with the new list.' (see Hoogle)
-- mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
on mapAccumR(f, acc, xs)
    script
        on |λ|(x, a, i)
            tell mReturn(f) to set pair to |λ|(|1| of a, x, i)
            Tuple(|1| of pair, (|2| of pair) & |2| of a)
        end |λ|
    end script
    foldr(result, Tuple(acc, []), xs)
end mapAccumR

-- min :: Ord a => a -> a -> a
on min(x, y)
    if y < x then
        y
    else
        x
    end if
end min

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

-- not :: Bool -> Bool
on |not|(p)
    not p
end |not|

-- Egyptian multiplication - progressively doubling a list, appending
-- stages of doubling to an accumulator where needed for binary
-- assembly of a target length
-- replicate :: Int -> a -> [a]
on replicate(n, a)
    set out to {}
    if n < 1 then return out
    set dbl to {a}

    repeat while (n > 1)
        if (n mod 2) > 0 then set out to out & dbl
        set n to (n div 2)
        set dbl to (dbl & dbl)
    end repeat
    return out & dbl
end replicate

-- unlines :: [String] -> String
on unlines(xs)
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, linefeed}
    set str to xs as text
    set my text item delimiters to dlm
    str
end unlines

-- unwords :: [String] -> String
on unwords(xs)
    set {dlm, my text item delimiters} to {my text item delimiters, space}
    set s to xs as text
    set my text item delimiters to dlm
    return s
end unwords

-- unwrap :: NSObject -> a
on unwrap(objCValue)
    if objCValue is missing value then
        missing value
    else
        set ca to current application
        item 1 of ((ca's NSArray's arrayWithObject:objCValue) as list)
    end if
end unwrap

-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
on zipWith(f, xs, ys)
    set lng to min(length of xs, length of ys)
    if 1 > lng then return {}
    set lst to {}
    tell mReturn(f)
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, item i of ys)
        end repeat
        return lst
    end tell
end zipWith


/* ARM assembly Raspberry PI  */
/*  program binarydigit.s   */
/* Constantes    */
.equ STDOUT, 1
.equ WRITE,  4
.equ EXIT,   1
/* Initialized data */
.data
szMessResultAnd: .asciz "Result of And : \n"
szMessResultOr: .asciz "Result of Or : \n"
szMessResultEor: .asciz "Result of Exclusif Or : \n"
szMessResultNot: .asciz "Result of Not : \n"
szMessResultLsl: .asciz "Result of left shift : \n"
szMessResultLsr: .asciz "Result of right shift : \n"
szMessResultAsr: .asciz "Result of Arithmetic right shift : \n"
szMessResultRor: .asciz "Result of rotate right : \n"
szMessResultRrx: .asciz "Result of rotate right with extend : \n"
szMessResultClear: .asciz "Result of Bit Clear : \n"

sMessAffBin: .ascii "Register value : "
sZoneBin: .space 36,' '
              .asciz "\n"

/*  code section */
.text
.global main
main:                /* entry of program  */
    push {fp,lr}    /* save des  2 registres */
    ldr r0,iAdrszMessResultAnd
    bl affichageMess
    mov r0,#5
    and r0,#15
    bl affichage2
    ldr r0,iAdrszMessResultOr
    bl affichageMess
    mov r0,#5
    orr r0,#15
    bl affichage2
    ldr r0,iAdrszMessResultEor
    bl affichageMess
    mov r0,#5
    eor r0,#15
    bl affichage2
    ldr r0,iAdrszMessResultNot
    bl affichageMess
    mov r0,#5
    mvn r0,r0
    bl affichage2
    ldr r0,iAdrszMessResultLsl
    bl affichageMess
    mov r0,#5
    lsl r0,#1
    bl affichage2
    ldr r0,iAdrszMessResultLsr
    bl affichageMess
    mov r0,#5
    lsr r0,#1
    bl affichage2
    ldr r0,iAdrszMessResultAsr
    bl affichageMess
    mov r0,#-5
    bl affichage2
    mov r0,#-5
    asr r0,#1
    bl affichage2
    ldr r0,iAdrszMessResultRor
    bl affichageMess
    mov r0,#5
    ror r0,#1
    bl affichage2
    ldr r0,iAdrszMessResultRrx
    bl affichageMess
    mov r0,#5
    mov r1,#15
    rrx r0,r1
    bl affichage2
	ldr r0,iAdrszMessResultClear
    bl affichageMess
	mov r0,#5
    bic r0,#0b100     @  clear 3ieme bit
    bl affichage2
	bic r0,#4          @  clear 3ieme bit  ( 4 = 100 binary)
    bl affichage2

100:   /* standard end of the program */
    mov r0, #0                  @ return code
    pop {fp,lr}                 @restaur 2 registers
    mov r7, #EXIT              @ request to exit program
    swi 0                       @ perform the system call
iAdrszMessResultAnd:  .int szMessResultAnd
iAdrszMessResultOr:  .int szMessResultOr
iAdrszMessResultEor:  .int szMessResultEor
iAdrszMessResultNot:  .int szMessResultNot
iAdrszMessResultLsl:  .int szMessResultLsl
iAdrszMessResultLsr:  .int szMessResultLsr
iAdrszMessResultAsr:  .int szMessResultAsr
iAdrszMessResultRor:  .int szMessResultRor
iAdrszMessResultRrx:  .int szMessResultRrx
iAdrszMessResultClear:  .int szMessResultClear
/******************************************************************/
/*     register display in binary                              */
/******************************************************************/
/* r0 contains the register */
affichage2:
    push {r0,lr}     /* save  registers */
    push {r1-r5} /* save others registers */
    mrs r5,cpsr  /* saves state register in r5 */
    ldr r1,iAdrsZoneBin
    mov r2,#0    @ read bit position counter
    mov r3,#0    @ position counter of the written character
1:               @ loop
    lsls r0,#1    @ left shift  with flags
    movcc r4,#48  @ flag carry off   character '0'
    movcs r4,#49  @ flag carry on    character '1'
    strb r4,[r1,r3]   @ character ->   display zone
    add r2,r2,#1      @ + 1 read bit position counter
    add r3,r3,#1      @ + 1 position counter of the written character
    cmp r2,#8         @ 8 bits read
    addeq r3,r3,#1   @ + 1 position counter of the written character
    cmp r2,#16         @ etc
    addeq r3,r3,#1
    cmp r2,#24
    addeq r3,r3,#1
    cmp r2,#31        @ 32 bits shifted ?
    ble 1b           @  no -> loop

    ldr r0,iAdrsZoneMessBin   @ address of message result
    bl affichageMess           @ display result

100:
    msr cpsr,r5    /*restaur state register */
    pop {r1-r5}  /* restaur others registers */
    pop {r0,lr}
    bx lr
iAdrsZoneBin: .int sZoneBin
iAdrsZoneMessBin: .int sMessAffBin

/******************************************************************/
/*     display text with size calculation                         */
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {fp,lr}    			/* save  registres */
    push {r0,r1,r2,r7}    		/* save others registres */
    mov r2,#0   				/* counter length */
1:      	/* loop length calculation */
    ldrb r1,[r0,r2]  			/* read octet start position + index */
    cmp r1,#0       			/* if 0 its over */
    addne r2,r2,#1   			/* else add 1 in the length */
    bne 1b          			/* and loop */
                                /* so here r2 contains the length of the message */
    mov r1,r0        			/* address message in r1 */
    mov r0,#STDOUT      		/* code to write to the standard output Linux */
    mov r7, #WRITE             /* code call system write */
    swi #0                      /* call systeme */
    pop {r0,r1,r2,r7}     		/* restaur others registres */
    pop {fp,lr}    				/* restaur des  2 registres */
    bx lr	        			/* return  */


V majors = ‘north east south west’.split(‘ ’)
majors *= 2
V quarter1 = ‘N,N by E,N-NE,NE by N,NE,NE by E,E-NE,E by N’.split(‘,’)
V quarter2 = quarter1.map(p -> p.replace(‘NE’, ‘EN’))

F degrees2compasspoint(=d)
   d = (d % 360) + 360 / 64
   V majorindex = Int(d / 90)
   V minorindex = Int((d % 90 * 4) I/ 45)
   V p1 = :majors[majorindex]
   V p2 = :majors[majorindex + 1]
   [String] q
   I p1 C (‘north’, ‘south’)
      q = :quarter1
   E
      q = :quarter2
   R q[minorindex].replace(‘N’, p1).replace(‘E’, p2).capitalize()

:start:
L(i) 33
   V d = i * 11.25
   S i % 3
      1
         d += 5.62
      2
         d -= 5.62
   V n = i % 32 + 1
   print(‘#2.0 #<18 #4.2°’.format(n, degrees2compasspoint(d), d))


a: 255
b: 2

print [a "AND" b "=" and a b]
print [a "OR" b "=" or a b]
print [a "XOR" b "=" xor a b]
print ["NOT" a "=" not a]
print [a "SHL" b "=" shl a b]
print [a "SHR" b "=" shr a b]


bitwise(3, 4)
bitwise(a, b)
{
  MsgBox % "a and b: " . a & b
  MsgBox % "a or b: " . a | b
  MsgBox % "a xor b: " . a ^ b
  MsgBox % "not a: " . ~a       ; treated as unsigned integer
  MsgBox % "a << b: " . a << b  ; left shift
  MsgBox % "a >> b: " . a >> b  ; arithmetic right shift
}


INCLUDE "D2:PRINTF.ACT" ;from the Action! Tool Kit
INCLUDE "D2:REAL.ACT" ;from the Action! Tool Kit

DEFINE PTR="CARD"

PROC InitNames(PTR ARRAY names)
  names(0)="N"    names(1)="NbE"
  names(2)="NNE"  names(3)="NEbN"
  names(4)="NE"   names(5)="NEbE"
  names(6)="ENE"  names(7)="EbN"
  names(8)="E"    names(9)="EbS"
  names(10)="ESE" names(11)="SEbE"
  names(12)="SE"  names(13)="SEbS"
  names(14)="SSE" names(15)="SbE"
  names(16)="S"   names(17)="SbW"
  names(18)="SSW" names(19)="SWbS"
  names(20)="SW"  names(21)="SWbW"
  names(22)="WSW" names(23)="WbS"
  names(24)="W"   names(25)="WbN"
  names(26)="WNW" names(27)="NWbW"
  names(28)="NW"  names(29)="NWbN"
  names(30)="NNW" names(31)="NbW"
  names(32)="N"
RETURN

PROC PrintIndex(BYTE i)
  CHAR ARRAY s(5)

  StrB(i,s)
  PrintF("%2S",s)
RETURN

BYTE FUNC FindDot(CHAR ARRAY s)
  BYTE i

  FOR i=1 TO s(0)
  DO
    IF s(i)='. THEN
      RETURN (i)
    FI
  OD
RETURN (0)

PROC PrintAngle(REAL POINTER a)
  CHAR ARRAY s(10)
  BYTE pos

  StrR(a,s)
  pos=FindDot(s)
  IF pos=0 THEN
    s(0)==+3
    s(s(0)-2)='.
    s(s(0)-1)='0
    s(s(0)-0)='0
  ELSEIF pos=s(0)-1 THEN
    s(0)==+1
    s(s(0)-0)='0
  FI
  PrintF("%6S",s)
RETURN

INT FUNC GetIndex(REAL POINTER a)
  REAL r32,r360,r1,r2

  IntToReal(32,r32)
  IntToReal(360,r360)
  RealMult(a,r32,r1)
  RealDiv(r1,r360,r2)
RETURN (RealToInt(r2))

PROC Main()
  DEFINE COUNT="33"
  PTR ARRAY names(COUNT)
  INT i,m,ind,x,y
  REAL ri,r11_25,r5_62,rh,r1

  Put(125) PutE() ;clear the screen
  InitNames(names)
  ValR("11.25",r11_25)
  ValR("5.62",r5_62)
  FOR i=0 TO 32
  DO
    IntToReal(i,ri)
    RealMult(ri,r11_25,rh)
    m=i MOD 3
    IF m=1 THEN
      RealAdd(rh,r5_62,r1)
      RealAssign(r1,rh)
    ELSEIF m=2 THEN
      RealSub(rh,r5_62,r1)
      RealAssign(r1,rh)
    FI
    ind=GetIndex(rh)

    IF i<16 THEN
      x=2 y=i+1
    ELSE
      x=20 y=i-15
    FI
    Position(x,y) PrintIndex(ind MOD (COUNT-1)+1)
    x==+3
    Position(x,y) Print(names(ind))
    x==+5
    Position(x,y) PrintAngle(rh)
  OD
RETURN


with Ada.Text_IO;

procedure Box_The_Compass is

   type Degrees is digits 5 range 0.00 .. 359.99;
   type Index_Type is mod 32;

   function Long_Name(Short: String) return String is

      function Char_To_Name(Char: Character) return String is
      begin
         case Char is
            when 'N' | 'n' => return Char & "orth";
            when 'S' | 's' => return Char & "outh";
            when 'E' | 'e' => return Char & "ast";
            when 'W' | 'w' => return Char & "est";
            when 'b' => return " by ";
            when '-' => return "-";
            when others => raise Constraint_Error;
         end case;
      end Char_To_Name;

   begin
      if Short'Length = 0 or else Short(Short'First)=' ' then
         return "";
      else
         return Char_To_Name(Short(Short'First))
           & Long_Name(Short(Short'First+1 .. Short'Last));
      end if;
   end Long_Name;

   procedure Put_Line(Angle: Degrees) is

      function Index(D: Degrees) return Index_Type is
      begin
         return Index_Type(Integer(Degrees'Rounding(D/11.25)) mod 32);
      end Index;

      I: Integer := Integer(Index(Angle))+1;
      package DIO is new Ada.Text_IO.Float_IO(Degrees);
      Abbr: constant array(Index_Type) of String(1 .. 4)
        := ("N   ", "Nbe ", "N-ne", "Nebn", "Ne  ", "Nebe", "E-ne", "Ebn ",
            "E   ", "Ebs ", "E-se", "Sebe", "Se  ", "Sebs", "S-se", "Sbe ",
            "S   ", "Sbw ", "S-sw", "Swbs", "Sw  ", "Swbw", "W-sw", "Wbs ",
            "W   ", "Wbn ", "W-nw", "Nwbw", "Nw  ", "Nwbn", "N-nw", "Nbw ");

   begin
      DIO.Put(Angle, Fore => 3, Aft => 2, Exp => 0); -- format "zzx.xx"
      Ada.Text_IO.Put(" |");
      if I <= 9 then
         Ada.Text_IO.Put(" ");
      end if;
      Ada.Text_IO.Put_Line(" "  & Integer'Image(I) & " | "
                             & Long_Name(Abbr(Index(Angle))));
   end Put_Line;

   Difference: constant array(0..2) of Degrees'Base
     := (0=> 0.0, 1=> +5.62, 2=> - 5.62);

begin
   Ada.Text_IO.Put_Line(" angle | box | compass point");
   Ada.Text_IO.Put_Line(" ---------------------------------");
   for I in 0 .. 32 loop
      Put_Line(Degrees(Degrees'Base(I) * 11.25 + Difference(I mod 3)));
   end loop;
end Box_The_Compass;


#!/usr/local/bin/a68g --script #

[]STRING
  long  by nesw = (" by ", "North", "East", "South", "West"),
  short by nesw = ("b", "N", "E", "S", "W");

MODE MINUTES = REAL; # minutes type #
INT last minute=360*60;
INT point width=last minute OVER 32;

PROC direction name = (REAL direction in minutes, []STRING locale directions)STRING: (

  STRING by = locale directions[1];
  []STRING nesw = locale directions[@-1];

  PRIO MASK = 7; # same PRIOrity as * and / #
  OP MASK = (INT n, BITS lower)INT: ABS (BIN n AND NOT lower),
     DECAP = (STRING s)STRING: IF UPB s > 1 THEN REPR (ABS s[1]-ABS "A"+ABS "a")+s[2:] ELSE s FI;

  PROC point name = (INT in point)STRING: (

    INT point = in point MOD 32 # 32 points of a compass #;
    IF point MOD 8 = 0 THEN
# name the principle point: eg. N, E, S or W #
      nesw[point OVER 8]

    ELIF point MOD 4 = 0 THEN
# name the half: eg. NE, SE, SW or NW #
      point name((point+8)MASK 2r1111)+DECAP point name(point MASK 2r1111 + 8)

    ELIF point MOD 2 = 0 THEN
# name the quarter: eg. N-NE, E-NE, E-SE, S-SE, S-SW, W-SW, W-NW or N-NW #
      point name((point+4)MASK 2r111)+"-"+point name(point MASK 2r111 + 4)

    ELSE # Name the sixteenth point: #
# eg. NbE,NEbN,NEbE,EbN,EbS,SEbE,SEbS,SbE,SbW,SWbS,SWbW,WbS,WbN,NWbW,NWbN,NbW #
      INT opp point = point OVER 8 + ABS NOT ODD (point OVER 2);
      point name((point+2)MASK 2r11)+ by +nesw(opp point MOD 4)
    FI
  );
  point name(ROUND(direction in minutes/point width))
);

PROC traditional name = (MINUTES minutes)STRING: (
  INT degrees = ROUND(minutes / 60);
  degrees=0  |"Tramontana"          |:
  degrees=45 |"Greco or Bora"       |:
  degrees=90 |"Levante"             |:
  degrees=135|"Sirocco"             |:
  degrees=180|"Ostro"               |:
  degrees=225|"Libeccio"            |:
  degrees=270|"Poniente or Zephyrus"|:
  degrees=315|"Mistral"             |:
  degrees=360|"Tramontana"          |""
);

# First generate the test set results #
test:(
  printf($"Test:"l$);
  FOR i FROM 0 TO 32 DO
    REAL heading = i * 11.25 +
      CASE i MOD 3 IN
        +5.62,
        -5.62
        OUT 0
      ESAC;
    INT index = ( i MOD 32) + 1;
    printf(($zd" ", g23k, zzd.zzl$, index , direction name(heading*60, long by nesw), heading))
  OD
);

table:(
  OP OVER = (REAL r, INT base)INT: ENTIER ABS r OVER  base,
     MOD = (REAL r, INT base)REAL: ( INT i = ENTIER r; i MOD base + r - i);

  printf(
    $l"Table:"l
    " #|Compass point"22k"|Abbr|Traditional wind point| Lowest°′ | Middle°′ | Highest°′"l$
  );

  OP DEGMIN = (REAL minutes)STRUCT(INT d, REAL m): (minutes MOD last minute OVER 60, minutes MOD 60);

  FOR point FROM 1 TO 32 DO
    REAL centre = (point-1) * point width;
    REAL from =  centre - point width/2,
         to   =  centre + point width/2-1/120;
    printf((
            $g(-2)"|"$, point,
            $g$, direction name(centre, long by nesw),
            $22k"|"g$, direction name(centre, short by nesw),
            $27k"|"g$, traditional name(centre),
            $50k$, $"|"g(-3)"°", dd.dd"′"$, DEGMIN from, DEGMIN centre, DEGMIN to,
            $l$
          ))
  OD
)


BEGIN {
  n = 11
  p = 1
  print n " or  " p " = " or(n,p)
  print n " and " p " = " and(n,p)
  print n " xor " p " = " xor(n,p)
  print n " <<  " p " = " lshift(n, p)   # left shift
  print n " >>  " p " = " rshift(n, p)   # right shift
  printf "not %d = 0x%x\n", n, compl(n)  # bitwise complement
}


Lbl BITS
r₁→A
r₂→B
Disp "AND:",A·B▶Dec,i
Disp "OR:",AᕀB▶Dec,i
Disp "XOR:",A▫B▶Dec,i
Disp "NOT:",not(A)ʳ▶Dec,i
.No language support for shifts or rotations
Return


use framework "Foundation"
use scripting additions

-- BOXING THE COMPASS --------------------------------------------------------

property plstLangs : [{|name|:"English"} & ¬
    {expansions:{N:"north", S:"south", E:"east", W:"west", b:" by "}} & ¬
    {|N|:"N", |NNNE|:"NbE", |NNE|:"N-NE", |NNENE|:"NEbN", |NE|:"NE", |NENEE|:"NEbE"} & ¬
    {|NEE|:"E-NE", |NEEE|:"EbN", |E|:"E", |EEES|:"EbS", |EES|:"E-SE", |EESES|:"SEbE"} & ¬
    {|ES|:"SE", |ESESS|:"SEbS", |ESS|:"S-SE", |ESSS|:"SbE", |S|:"S", |SSSW|:"SbW"} & ¬
    {|SSW|:"S-SW", |SSWSW|:"SWbS", |SW|:"SW", |SWSWW|:"SWbW", |SWW|:"W-SW"} & ¬
    {|SWWW|:"WbS", |W|:"W", |WWWN|:"WbN", |WWN|:"W-NW", |WWNWN|:"NWbW"} & ¬
    {|WN|:"NW", |WNWNN|:"NWbN", |WNN|:"N-NW", |WNNN|:"NbW"}, ¬
    ¬
        {|name|:"Chinese", |N|:"北", |NNNE|:"北微东", |NNE|:"东北偏北"} & ¬
    {|NNENE|:"东北微北", |NE|:"东北", |NENEE|:"东北微东", |NEE|:"东北偏东"} & ¬
    {|NEEE|:"东微北", |E|:"东", |EEES|:"东微南", |EES|:"东南偏东", |EESES|:"东南微东"} & ¬
    {|ES|:"东南", |ESESS|:"东南微南", |ESS|:"东南偏南", |ESSS|:"南微东", |S|:"南"} & ¬
    {|SSSW|:"南微西", |SSW|:"西南偏南", |SSWSW|:"西南微南", |SW|:"西南"} & ¬
    {|SWSWW|:"西南微西", |SWW|:"西南偏西", |SWWW|:"西微南", |W|:"西"} & ¬
    {|WWWN|:"西微北", |WWN|:"西北偏西", |WWNWN|:"西北微西", |WN|:"西北"} & ¬
    {|WNWNN|:"西北微北", |WNN|:"西北偏北", |WNNN|:"北微西"}]

--  Scale invariant keys for points of the compass
-- (allows us to look up a translation for one scale of compass (32 here)
-- for use in another size of compass (8 or 16 points)
-- (Also semi-serviceable as more or less legible keys without translation)

-- compassKeys :: Int -> [String]
on compassKeys(intDepth)
    -- Simplest compass divides into two hemispheres
    -- with one peak of ambiguity to the left,
    -- and one to the right  (encoded by the commas in this list):
    set urCompass to ["N", "S", "N"]

    -- Necessity drives recursive subdivision of broader directions, shrinking
    -- boxes down to a workable level of precision:
    script subdivision
        on |λ|(lstCompass, N)
            if N ≤ 1 then
                lstCompass
            else
                script subKeys
                    on |λ|(a, x, i, xs)
                        -- Borders between N and S engender E and W.
                        -- further subdivisions (boxes)
                        -- concatenate their two parent keys.
                        if i > 1 then
                            cond(N = intDepth, ¬
                                a & {cond(x = "N", "W", "E")} & x, ¬
                                a & {item (i - 1) of xs & x} & x)
                        else
                            a & x
                        end if
                    end |λ|
                end script

                |λ|(foldl(subKeys, {}, lstCompass), N - 1)
            end if
        end |λ|
    end script

    tell subdivision to items 1 thru -2 of |λ|(urCompass, intDepth)
end compassKeys

-- pointIndex :: Int -> Num -> String
on pointIndex(power, degrees)
    set nBoxes to 2 ^ power
    set i to round (degrees + (360 / (nBoxes * 2))) ¬
        mod 360 * nBoxes / 360 rounding up
    cond(i > 0, i, 1)
end pointIndex

-- pointNames :: Int -> Int -> [String]
on pointNames(precision, iBox)
    set k to item iBox of compassKeys(precision)

    script translation
        on |λ|(recLang)
            set maybeTrans to keyValue(recLang, k)
            set strBrief to cond(maybeTrans is missing value, k, maybeTrans)

            set recExpand to keyValue(recLang, "expansions")

            if recExpand is not missing value then
                script expand
                    on |λ|(c)
                        set t to keyValue(recExpand, c)
                        cond(t is not missing value, t, c)
                    end |λ|
                end script
                set strName to (intercalate(cond(precision > 5, " ", ""), ¬
                    map(expand, characters of strBrief)))
                toUpper(text item 1 of strName) & text items 2 thru -1 of strName
            else
                strBrief
            end if
        end |λ|
    end script

    map(translation, plstLangs)
end pointNames

-- maxLen :: [String] -> Int
on maxLen(xs)
    length of maximumBy(comparing(my |length|), xs)
end maxLen

-- alignRight :: Int -> String -> String
on alignRight(nWidth, x)
    justifyRight(nWidth, space, x)
end alignRight

-- alignLeft :: Int -> String -> String
on alignLeft(nWidth, x)
    justifyLeft(nWidth, space, x)
end alignLeft

-- show :: asString => a -> Text
on show(x)
    x as string
end show

-- compassTable :: Int -> [Num] -> Maybe String
on compassTable(precision, xs)
    if precision < 1 then
        missing value
    else
        set intPad to 2
        set rightAligned to curry(alignRight)
        set leftAligned to curry(alignLeft)
        set join to curry(my intercalate)

        -- INDEX COLUMN
        set lstIndex to map(|λ|(precision) of curry(pointIndex), xs)
        set lstStrIndex to map(show, lstIndex)
        set nIndexWidth to maxLen(lstStrIndex)
        set colIndex to map(|λ|(nIndexWidth + intPad) of rightAligned, lstStrIndex)

        -- ANGLES COLUMN
        script degreeFormat
            on |λ|(x)
                set {c, m} to splitOn(".", x as string)
                c & "." & (text 1 thru 2 of (m & "0")) & "°"
            end |λ|
        end script
        set lstAngles to map(degreeFormat, xs)
        set nAngleWidth to maxLen(lstAngles) + intPad
        set colAngles to map(|λ|(nAngleWidth) of rightAligned, lstAngles)

        -- NAMES COLUMNS
        script precisionNames
            on |λ|(iBox)
                pointNames(precision, iBox)
            end |λ|
        end script

        set lstTrans to transpose(map(precisionNames, lstIndex))
        set lstTransWidths to map(maxLen, lstTrans)

        script spacedNames
            on |λ|(lstLang, i)
                map(|λ|((item i of lstTransWidths) + 2) of leftAligned, lstLang)
            end |λ|
        end script

        set colsTrans to map(spacedNames, lstTrans)

        -- TABLE
        intercalate(linefeed, ¬
            map(|λ|("") of join, ¬
                transpose({colIndex} & {colAngles} & ¬
                    {replicate(length of lstIndex, "  ")} & colsTrans)))
    end if
end compassTable

-- TEST ----------------------------------------------------------------------
on run
    set xs to [0.0, 16.87, 16.88, 33.75, 50.62, 50.63, 67.5, 84.37, ¬
        84.38, 101.25, 118.12, 118.13, 135.0, 151.87, 151.88, 168.75, ¬
        185.62, 185.63, 202.5, 219.37, 219.38, 236.25, 253.12, 253.13, ¬
        270.0, 286.87, 286.88, 303.75, 320.62, 320.63, 337.5, 354.37, ¬
        354.38]

    --   If we supply other precisions, like 4 or 6, (2^n -> 16 or 64 boxes)
    --    the bearings will be divided amongst smaller or larger numbers of boxes,
    --    either using name translations retrieved by the generic hash
    --    or using the keys of the hash itself (combined with any expansions)
    --    to substitute for missing names for very finely divided boxes.

    compassTable(5, xs) -- // 2^5  -> 32 boxes
end run

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

-- comparing :: (a -> b) -> (a -> a -> Ordering)
on comparing(f)
    set mf to mReturn(f)
    script
        on |λ|(a, b)
            set x to mf's |λ|(a)
            set y to mf's |λ|(b)
            if x < y then
                -1
            else
                if x > y then
                    1
                else
                    0
                end if
            end if
        end |λ|
    end script
end comparing

-- cond :: Bool -> a -> a -> a
on cond(bool, f, g)
    if bool then
        f
    else
        g
    end if
end cond

-- curry :: (Script|Handler) -> Script
on curry(f)
    script
        on |λ|(a)
            script
                on |λ|(b)
                    |λ|(a, b) of mReturn(f)
                end |λ|
            end script
        end |λ|
    end script
end curry

-- foldl :: (a -> b -> a) -> a -> [b] -> a
on foldl(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from 1 to lng
            set v to |λ|(v, item i of xs, i, xs)
        end repeat
        return v
    end tell
end foldl

-- intercalate :: Text -> [Text] -> Text
on intercalate(strText, lstText)
    set {dlm, my text item delimiters} to {my text item delimiters, strText}
    set strJoined to lstText as text
    set my text item delimiters to dlm
    return strJoined
end intercalate

-- justifyLeft :: Int -> Char -> Text -> Text
on justifyLeft(N, cFiller, strText)
    if N > length of strText then
        text 1 thru N of (strText & replicate(N, cFiller))
    else
        strText
    end if
end justifyLeft

-- justifyRight :: Int -> Char -> Text -> Text
on justifyRight(N, cFiller, strText)
    if N > length of strText then
        text -N thru -1 of ((replicate(N, cFiller) as text) & strText)
    else
        strText
    end if
end justifyRight

-- keyValue :: Record -> String -> Maybe String
on keyValue(rec, strKey)
    set ca to current application
    set v to (ca's NSDictionary's dictionaryWithDictionary:rec)'s objectForKey:strKey
    if v is not missing value then
        item 1 of ((ca's NSArray's arrayWithObject:v) as list)
    else
        missing value
    end if
end keyValue

-- length :: [a] -> Int
on |length|(xs)
    length of xs
end |length|

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- maximumBy :: (a -> a -> Ordering) -> [a] -> a
on maximumBy(f, xs)
    set cmp to mReturn(f)
    script max
        on |λ|(a, b)
            if a is missing value or cmp's |λ|(a, b) < 0 then
                b
            else
                a
            end if
        end |λ|
    end script

    foldl(max, missing value, xs)
end maximumBy

-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn

-- replicate :: Int -> a -> [a]
on replicate(N, a)
    set out to {}
    if N < 1 then return out
    set dbl to {a}

    repeat while (N > 1)
        if (N mod 2) > 0 then set out to out & dbl
        set N to (N div 2)
        set dbl to (dbl & dbl)
    end repeat
    return out & dbl
end replicate

-- splitOn :: Text -> Text -> [Text]
on splitOn(strDelim, strMain)
    set {dlm, my text item delimiters} to {my text item delimiters, strDelim}
    set xs to text items of strMain
    set my text item delimiters to dlm
    return xs
end splitOn

-- transpose :: [[a]] -> [[a]]
on transpose(xss)
    script column
        on |λ|(_, iCol)
            script row
                on |λ|(xs)
                    item iCol of xs
                end |λ|
            end script

            map(row, xss)
        end |λ|
    end script

    map(column, item 1 of xss)
end transpose

-- toLower :: String -> String
on toLower(str)
    set ca to current application
    ((ca's NSString's stringWithString:(str))'s ¬
        lowercaseStringWithLocale:(ca's NSLocale's currentLocale())) as text
end toLower

-- toTitle :: String -> String
on toTitle(str)
    set ca to current application
    ((ca's NSString's stringWithString:(str))'s ¬
        capitalizedStringWithLocale:(ca's NSLocale's currentLocale())) as text
end toTitle

-- toUpper :: String -> String
on toUpper(str)
    set ca to current application
    ((ca's NSString's stringWithString:(str))'s ¬
        uppercaseStringWithLocale:(ca's NSLocale's currentLocale())) as text
end toUpper


({5 9}) ({cand} {cor} {cnor} {cxor} {cxnor} {shl} {shr} {ashr} {rol}) cart ! {give <- cp -> compose !} over ! {eval} over ! {;} each


SUB bitwise (a, b)
  PRINT a AND b
  PRINT a OR b
  PRINT a XOR b
  PRINT NOT a
END SUB


# bitwise operators - floating point numbers will be cast to integer
a = 0b00010001
b = 0b11110000
print a
print int(a * 2)  # shift left (multiply by 2)
print a \ 2  # shift right (integer divide by 2)
print a | b  # bitwise or on two integer values
print a & b  # bitwise or on two integer values


@echo off
setlocal
set /a "a=%~1, b=%~2"
call :num2bin %a% aStr
call :num2bin %b% bStr

::AND
set /a "val=a&b"
call :display "%a% AND %b%" %val% %aStr% %bStr%

::OR
set /a "val=a|b"
call :display "%a% OR %b%" %val% %aStr% %bStr%

::XOR
set /a "val=a^b"
call :display "%a% XOR %b%" %val% %aStr% %bStr%

::NOT
set /a "val=~a"
call :display "NOT %a%" %val% %aStr%

::LEFT SHIFT
set /a "val=a<<b"
call :display "%a% Left Shift %b%" %val% %aStr%

::ARITHMETIC RIGHT SHIFT
set /a "val=a>>b"
call :display "%a% Arithmetic Right Shift %b%" %val% %aStr%

::The remaining operations do not have native support
::The implementations use additional operators
::  %% = mod
::  ! = logical negation where !(zero)=1 and !(non-zero)=0
::  * = multiplication
::  - = subtraction

::LOGICAL RIGHT SHIFT (No native support)
set /a "val=(a>>b)&~((0x80000000>>b-1)*!!b)"
call :display "%a% Logical Right Shift %b%" %val% %aStr%

::ROTATE LEFT (No native support)
set /a "val=(a<<b%%32) | (a>>32-b%%32)&~((0x80000000>>31-b%%32)*!!(32-b%%32))"
call :display "%a% Rotate Left %b%" %val% %aStr%

::ROTATE RIGHT (No native support)
set /a "val=(a<<32-b%%32) | (a>>b%%32)&~((0x80000000>>b%%32-1)*!!(b%%32)) "
call :display "%a% Rotate Right %b%" %val% %aStr%

exit /b

:display op result aStr [bStr]
echo(
echo %~1 = %2
echo %3
if "%4" neq "" echo %4
call :num2bin %2
exit /b

:num2bin    IntVal [RtnVar]
  setlocal enableDelayedExpansion
  set n=%~1
  set rtn=
  for /l %%b in (0,1,31) do (
    set /a "d=n&1, n>>=1"
    set rtn=!d!!rtn!
  )
  (endlocal & rem -- return values
    if "%~2" neq "" (set %~2=%rtn%) else echo %rtn%
  )
exit /b


Local $avArray[33] = [0.0, 16.87, 16.88, 33.75, 50.62, 50.63, 67.5, 84.37, 84.38, 101.25, 118.12, 118.13, 135.0, _
		151.87, 151.88, 168.75, 185.62, 185.63, 202.5, 219.37, 219.38, 236.25, 253.12, 253.13, 270.0, 286.87, 286.88, _
		303.75, 320.62, 320.63, 337.5, 354.37, 354.38]

For $i = 0 To UBound($avArray) - 1
	Boxing_the_compass($avArray[$i])
Next

Func Boxing_the_compass($Degree)
	Local $namearray[33] = ["North", "North by east", "North-northeast", "Northeast by north", "Northeast", _
			"Northeast by east", "East-northeast", "East by north", "East", "East by south", "East-southeast", _
			"Southeast by east", "Southeast", "Southeast by south", "South-southeast", "South by east", "South", _
			"South by west", "South-southwest", "Southwest by south", "Southwest", "Southwest by west", "West-southwest", _
			"West by south", "West", "West by north", "West-northwest", "Northwest by west", "Northwest", "Northwest by north", _
			"North-northwest", "North by west", "North"]
	ConsoleWrite(StringFormat("%-2s", Mod(Floor($Degree / 11.25 + 0.5), 32)) & " : " & _
			StringFormat("%-20s", $namearray[Mod(Floor($Degree / 11.25 + 0.5), 32)]) & " : " & $Degree & @CRLF)
EndFunc   ;==>Boxing_the_compass


      number1% = &89ABCDEF
      number2% = 8

      PRINT ~ number1% AND number2% : REM bitwise AND
      PRINT ~ number1% OR number2%  : REM bitwise OR
      PRINT ~ number1% EOR number2% : REM bitwise exclusive-OR
      PRINT ~ NOT number1%          : REM bitwise NOT
      PRINT ~ number1% << number2%  : REM left shift
      PRINT ~ number1% >>> number2% : REM right shift (logical)
      PRINT ~ number1% >> number2%  : REM right shift (arithmetic)
      PRINT ~ (number1% << number2%) OR (number1% >>> (32-number2%)) : REM left rotate
      PRINT ~ (number1% >>> number2%) OR (number1% << (32-number2%)) : REM right rotate


#eX~T~T_#
###>N{` AND `~{~` = `&{Nz1~3J
UXe#
##>{` OR  `~{~` = `|{Nz1~5J
UXe#
##>{` XOR `~{~` = `${Nz1~7J
UXe#
##>`NOT `{` = `!{Nz1~9J
UXe#
##>{` <<  `~{~` = `({Nz1~9PPJ
UXe#
##>{` >>> `~{~` = `){` (logical shift right)`N7F+M~1~J
UXe#
##>{` ROL `~{~` = `[{N7F+P~1~J
UXe#
##>{` ROR `~{~` = `]{NN8F+P~1~J
UXe#
##>`Arithmetic shift right is not originally implemented in beeswax.`N     q
 qN`,noitagen yb dezilaer eb nac srebmun evitagen rof RSA ,yllacinhcet tuB`N<
##>`logical shift right, and negating the result again:`NN7F++~1~J
UXe#      #>e#
 #>~1~[&'pUX{` >> `~{~` = `){` , interpreted as (positive) signed Int64 number (MSB=0), equivalent to >>>`NN;
          ###
         >UX`-`!P{M!` >> `~{~` = `!)!`-`M!{` , interpreted as (negative) signed Int64 number (MSB=1)`NN;
           #>e#


#!/usr/bin/awk -f
BEGIN {
  split("N NbE NNE NEbN NE NEbE ENE EbN E EbS ESE SEbE SE SEbS SSE SbE S SbW SSW SWbS SW SWbW WSW WbS W WbN WNW NWbW NW NWbN NNW NbW",A," ");
}

function ceil(x) {
	y = int(x)
	return y < x ? y + 1 : y
}

function compassbox(d) {
    return ceil( ( (d + 360 / 64) % 360) * 32 / 360);
}

{
    box = compassbox($1);
    printf "%6.2f : %2d\t%s\n",$1,box,A[box];
}


void bitwise(int a, int b)
{
  printf("a and b: %d\n", a & b);
  printf("a or b: %d\n", a | b);
  printf("a xor b: %d\n", a ^ b);
  printf("not a: %d\n", ~a);
  printf("a << n: %d\n", a << b); /* left shift */
  printf("a >> n: %d\n", a >> b); /* on most platforms: arithmetic right shift */
  /* convert the signed integer into unsigned, so it will perform logical shift */
  unsigned int c = a;
  printf("c >> b: %d\n", c >> b); /* logical right shift */
  /* there are no rotation operators in C */
  return 0;
}


arraybase 1

dim names$ = {"North", "North by east", "North-northeast", "Northeast by north", "Northeast", "Northeast by east", "East-northeast", "East by north", "East", "East by south", "East-southeast", "Southeast by east", "Southeast", "Southeast by south", "South-southeast", "South by east", "South", "South by west", "South-southwest", "Southwest by south", "Southwest", "Southwest by west", "West-southwest", "West by south", "West", "West by north", "West-northwest", "Northwest by west", "Northwest", "Northwest by north", "North-northwest", "North by west", "North"}

dim grados = {0, 16.87, 16.88, 33.75, 50.62, 50.63, 67.5, 84.37, 84.38, 101.25, 118.12, 118.13, 135, 151.87, 151.88, 168.75, 185.62, 185.63, 202.5, 219.37, 219.38, 236.25, 253.12, 253.13, 270, 286.87, 286.88, 303.75, 320.62, 320.63, 337.5, 354.37, 354.38}

for i = grados[?,] to grados[?]
    j = int((grados[i] + 5.625) / 11.25)
    if j > 31 then j -= 32
    print rjust(string(j),2); " "; ljust(string(names$[j+1]),20); grados[i]
next i


static void bitwise(int a, int b)
        {
            Console.WriteLine("a and b is {0}", a & b);
            Console.WriteLine("a or b is {0}", a | b);
            Console.WriteLine("a xor b is {0}", a ^ b);
            Console.WriteLine("not a is {0}", ~a);
            Console.WriteLine("a lshift b is {0}", a << b);
            Console.WriteLine("a arshift b is {0}", a >> b); // When the left operand of the >> operator is of a signed integral type,
                                                             // the operator performs an arithmetic shift right
            uint c = (uint)a;
            Console.WriteLine("c rshift b is {0}", c >> b); // When the left operand of the >> operator is of an unsigned integral type,
                                                            // the operator performs a logical shift right
            // there are no rotation operators in C#
        }