{-# LANGUAGE RecursiveDo #-}
import Reflex.Dom
import Data.Map as DM (Map, lookup, insert, empty, fromList)
import Data.Matrix
import Data.Time.Clock
import Control.Monad.Trans

size = 500
updateFrequency = 0.2
rotationStep = pi/10

data Color = Red | Green | Blue | Yellow | Orange | Purple | Black deriving (Show,Eq,Ord,Enum)

zRot :: Float -> Matrix Float
zRot rotation =
    let c = cos rotation
        s = sin rotation
    in fromLists [[ c,  s,  0,  0 ]
                 ,[-s,  c,  0,  0 ]
                 ,[ 0,  0,  1,  0 ]
                 ,[ 0,  0,  0,  1 ]
                 ]

xRot :: Float -> Matrix Float
xRot rotation =
    let c = cos rotation
        s = sin rotation
    in fromLists [[ 1,  0,  0,  0 ]
                 ,[ 0,  c,  s,  0 ]
                 ,[ 0, -s,  c,  0 ]
                 ,[ 0,  0,  0,  1 ]
                 ]

yRot :: Float -> Matrix Float
yRot rotation =
    let c = cos rotation
        s = sin rotation
    in fromLists [[ c,  0, -s,  0 ]
                 ,[ 0,  1,  0,  0 ]
                 ,[ s,  0,  c,  0 ]
                 ,[ 0,  0,  0,  1 ]
                 ]

translation :: (Float,Float,Float) -> Matrix Float
translation (x,y,z) =
    fromLists  [[ 1,  0,  0,  0 ]
               ,[ 0,  1,  0,  0 ]
               ,[ 0,  0,  1,  0 ]
               ,[ x,  y,  z,  1 ]
               ]

scale :: Float -> Matrix Float
scale s =
    fromLists  [[ s,  0,  0,  0 ]
               ,[ 0,  s,  0,  0 ]
               ,[ 0,  0,  s,  0 ]
               ,[ 0,  0,  0,  1 ]
               ]

-- perspective transformation;
perspective :: Matrix Float
perspective =
    fromLists  [[ 1,  0,  0,  0 ]
               ,[ 0,  1,  0,  0 ]
               ,[ 0,  0,  1,  1 ]
               ,[ 0,  0,  1,  1 ] ]

transformPoints :: Matrix Float -> Matrix Float -> [(Float,Float)]
transformPoints transform points =
    let result4d = points `multStd2` transform
        result2d = (\[x,y,z,w] -> (x/w,y/w)) <$> toLists result4d
    in result2d

showRectangle :: MonadWidget t m => Float -> Float -> Float -> Float -> Color -> Dynamic t (Matrix Float) -> m ()
showRectangle x0 y0 x1 y1 faceColor dFaceView = do
    let points = fromLists [[x0,y0,0,1],[x0,y1,0,1],[x1,y1,0,1],[x1,y0,0,1]]
        pointsToString = concatMap (\(x,y) -> show x ++ ", " ++ show y ++ " ")
    dAttrs <- mapDyn (\fvk -> DM.fromList [ ("fill", show faceColor)
                                          , ("points", pointsToString (transformPoints fvk points))
                                          ] ) dFaceView
    elDynAttrSVG "polygon" dAttrs $ return ()

showUnitSquare :: MonadWidget t m => Color -> Float -> Dynamic t (Matrix Float) -> m ()
showUnitSquare faceColor margin dFaceView =
    showRectangle margin margin (1.0 - margin) (1.0 - margin) faceColor dFaceView

-- show colored square on top of black square for outline effect
showFace :: MonadWidget t m => Color -> Dynamic t (Matrix Float) -> m ()
showFace faceColor dFaceView = do
    showUnitSquare Black 0 dFaceView
    showUnitSquare faceColor 0.03 dFaceView

facingCamera :: [Float] -> Matrix Float -> Bool
facingCamera viewPoint modelTransform =
    let cross [x0,y0,z0] [x1,y1,z1] = [y0*z1-z0*y1, z0*x1-x0*z1, x0*y1-y0*x1 ]
        dot v0 v1 = sum $ zipWith (*) v0 v1
        vMinus = zipWith (-)

        untransformedPoints = fromLists [ [0,0,0,1]   -- lower left
                                        , [1,0,0,1]   -- lower right
                                        , [0,1,0,1] ] -- upper left

        transformedPoints = toLists $ untransformedPoints `multStd2` modelTransform
        pt00 = take 3 $ head transformedPoints         -- transformed lower left
        pt10 = take 3 $ transformedPoints !! 1         -- transformed upper right
        pt01 = take 3 $ transformedPoints !! 2         -- transformed upper left

        tVec_10_00 = pt10 `vMinus` pt00                -- lower right to lower left
        tVec_01_00 = pt01 `vMinus` pt00                -- upper left to lower left
        perpendicular = tVec_10_00 `cross` tVec_01_00  -- perpendicular to face
        cameraToPlane = pt00 `vMinus` viewPoint        -- line of sight to face

        -- Perpendicular points away from surface;
        -- Camera vector points towards surface
        -- Opposed vectors means that face will be visible.
    in cameraToPlane `dot` perpendicular < 0

faceView :: Matrix Float -> Matrix Float -> (Bool, Matrix Float)
faceView modelOrientation faceOrientation =
    let modelTransform =            translation (-1/2,-1/2,1/2) -- unit square to origin + z offset
                         `multStd2` faceOrientation             -- orientation specific to each face
                         `multStd2` scale (1/2)                 -- shrink cube to fit in view.
                         `multStd2` modelOrientation            -- position the entire cube

        isFacingCamera = facingCamera [0,0,-1] modelTransform   -- backface elimination

        -- combine to get single transform from 2d face to 2d display
        viewTransform =            modelTransform
                        `multStd2` perspective
                        `multStd2` scale size                       -- scale up to svg box scale
                        `multStd2` translation (size/2, size/2, 0)  -- move to center of svg box

    in (isFacingCamera, viewTransform)

updateFaceViews :: Matrix Float -> Map Color (Matrix Float) -> (Color, Matrix Float) -> Map Color (Matrix Float)
updateFaceViews modelOrientation prevCollection (faceColor, faceOrientation) =
    let (isVisible, newFaceView) = faceView modelOrientation faceOrientation
    in  if isVisible
        then insert faceColor newFaceView prevCollection
        else prevCollection

faceViews :: Matrix Float -> Map Color (Matrix Float)
faceViews modelOrientation  =
    foldl (updateFaceViews modelOrientation) empty
          [ (Purple , xRot (0.0) )
          , (Yellow , xRot (pi/2) )
          , (Red    , yRot (pi/2) )
          , (Green  , xRot (-pi/2) )
          , (Blue   , yRot (-pi/2) )
          , (Orange , xRot (pi) )
          ]

viewModel :: MonadWidget t m => Dynamic t (Matrix Float) -> m ()
viewModel modelOrientation = do
    faceMap <- mapDyn faceViews modelOrientation
    listWithKey faceMap showFace
    return ()

view :: MonadWidget t m => Dynamic t (Matrix Float) -> m ()
view modelOrientation = do
    el "h1" $ text "Rotating Cube"
    elDynAttrSVG "svg"
        (constDyn $  DM.fromList [ ("width",  show size), ("height", show size) ])
        $ viewModel modelOrientation

main = mainWidget $ do
    let initialOrientation = xRot (pi/4) `multStd2` zRot (atan(1/sqrt(2)))
        update _ modelOrientation = modelOrientation `multStd2` (yRot (rotationStep) )

    tick <- tickLossy  updateFrequency =<< liftIO getCurrentTime
    rec
        view modelOrientation
        modelOrientation <- foldDyn update initialOrientation tick
    return ()

-- At end because of Rosetta Code handling of unmatched quotes.
elDynAttrSVG a2 a3 a4 = do
    elDynAttrNS' (Just "http://www.w3.org/2000/svg") a2 a3 a4
    return ()


require'gl2 gles ide/qt/opengl'
coinsert'jgl2 jgles qtopengl'

rotcube=: {{
  if.0=nc<'sprog'do.return.end.
  fixosx=. 'opengl';'opengl',('DARWIN'-:UNAME)#' version 4.1'
  wd 'pc rot; minwh 300 300; cc cube opengl flush' rplc fixosx
  HD=: ".wd 'qhwndc cube'
  wd 'ptimer 17; pshow'
}}

rot_close=: {{
  wd 'ptimer 0'
  glDeleteBuffers ::0: 2; vbo
  glDeleteProgram ::0: sprog
  erase 'sprog'
  wd 'pclose'
}}

cstr=: {{if.y do.memr y,0 _1 2 else.EMPTY end.}}
gstr=: {{cstr>{.glGetString y}}
diag=: {{p[echo y,': ',p=.gstr".y}}

blitf=: {{
  dat=. 1 fc,y NB. short floats
  glBindBuffer GL_ARRAY_BUFFER; x{vbo
  glBufferData GL_ARRAY_BUFFER; (#dat); (symdat<'dat'); GL_STATIC_DRAW
}}

rot_cube_initialize=: {{
  erase'sprog'
  if.0=#diag 'GL_VERSION' do.echo 'cannot retrieve GL_VERSION' return.end.
  diag each;:'GL_VENDOR GL_RENDERER GL_SHADING_LANGUAGE_VERSION'
  GLSL=:wglGLSL''
  wglPROC''
  'err program'=. gl_makeprogram VSRC ;&fixversion FSRC
  if.#err do. echo 'err: ', err return.end.
  if. GLSL>120 do.vao=: >{:glGenVertexArrays 1;,_1 end.
  assert _1~:vertexAttr=: >{.glGetAttribLocation program;'vertex'
  assert _1~:colorAttr=: >{.glGetAttribLocation program;'color'
  assert _1~:mvpUni=: >{.glGetUniformLocation program;'mvp'
  vbo=: >{:glGenBuffers 2;2#_1
  0 blitf vertexData
  1 blitf colorData
  sprog=: program
}}

VSRC=: {{)n
  #version $version
  $v_in $highp vec3 vertex;
  $v_in $lowp vec3 color;
  $v_out $lowp vec4 v_color;
  uniform mat4 mvp;
  void main(void) {
    gl_Position= mvp * vec4(vertex,1.0);
    v_color= vec4(color,1.0);
  }
}}

FSRC=: {{)n
  #version $version
  $f_in $lowp vec4 v_color;
  $fragColor
  void main(void) {
    $gl_fragColor= v_color;
  }
}}

fixversion=: {{
  NB. cope with host shader language version
  r=.   '$version';GLSL,&":;(GLSL>:300)#(*GLES_VERSION){' core';' es'
  f1=. GLSL<:120
  r=.r, '$v_in';f1{'in';'attribute'
  r=.r, '$v_out';f1{'out';'varying'
  r=.r, '$f_in';f1{'in';'varying'
  r=.r, '$highp ';f1#(*GLES_VERSION)#'highp'
  r=.r, '$lowp ';f1#(*GLES_VERSION)#'lowp'
  f2=.(330<:GLSL)+.(300<:GLSL)**GLES_VERSION
  r=.r, '$gl_fragColor';f2{'gl_FragColor';'fragColor'
  r=.r, '$fragColor';f2#'out vec4 fragColor;'
  y rplc r
}}

rot_timer=: {{
  try.
    gl_sel HD
    gl_paint''
  catch.
     echo 'error in rot_timer',LF,13!:12''
     wd'ptimer 0'
  end.
}}

zeroVAttr=: {{
  glEnableVertexAttribArray y
  glBindBuffer GL_ARRAY_BUFFER; x{vbo
  glVertexAttribPointer y; 3; GL_FLOAT; 0; 0; 0
}}

mp=: +/ .*
ref=: (gl_Translate 0 0 _10) mp glu_LookAt 0 0 1,0 0 0,1 0 0
rot_cube_paint=: {{
  try.
    if.nc<'sprog' do.return.end.
    wh=. gl_qwh''
    glClear GL_COLOR_BUFFER_BIT+GL_DEPTH_BUFFER_BIT [glClearColor 0 0 0 0+%3
    glUseProgram sprog
    glEnable each GL_DEPTH_TEST, GL_CULL_FACE, GL_BLEND
    glBlendFunc GL_SRC_ALPHA; GL_ONE_MINUS_SRC_ALPHA
    mvp=. (gl_Rotate (360|60*6!:1''),1 0 0)mp ref mp gl_Perspective 30, (%/wh),1 20
    glUniformMatrix4fv mvpUni; 1; GL_FALSE; mvp
    if. GLSL>120 do. glBindVertexArray {.vao end.
    0 zeroVAttr vertexAttr
    1 zeroVAttr colorAttr
    glDrawArrays GL_TRIANGLES; 0; 36
    glUseProgram 0
  catch.
    echo 'error in rot_cube_paint',LF,13!:12''
    wd'ptimer 0'
  end.
}}

NB. oriented triangle representation of unit cube
unitCube=:  #:(0 1 2, 2 1 3)&{@".;._2 {{)n
  2 3 0 1 NB. unit cube corner indices
  3 7 1 5 NB. 0: origin
  4 0 5 1 NB. 1, 2, 4: unit distance along each axis
  6 2 4 0 NB. 3, 5, 6, 7:  combinations of axes
  7 6 5 4
  7 3 6 2
}}

NB. orient cube so diagonal is along first axis
daxis=: (_1^5 6 e.~i.3 3)*%:6%~2 0 4,2 3 1,:2 3 1
vertexData=:(_1^unitCube)mp daxis NB. cube with center at origin
colorData=: unitCube NB. corresponding colors

rotcube''


import java.awt.*;
import java.awt.event.ActionEvent;
import static java.lang.Math.*;
import javax.swing.*;

public class RotatingCube extends JPanel {
    double[][] nodes = {{-1, -1, -1}, {-1, -1, 1}, {-1, 1, -1}, {-1, 1, 1},
    {1, -1, -1}, {1, -1, 1}, {1, 1, -1}, {1, 1, 1}};

    int[][] edges = {{0, 1}, {1, 3}, {3, 2}, {2, 0}, {4, 5}, {5, 7}, {7, 6},
    {6, 4}, {0, 4}, {1, 5}, {2, 6}, {3, 7}};

    public RotatingCube() {
        setPreferredSize(new Dimension(640, 640));
        setBackground(Color.white);

        scale(100);
        rotateCube(PI / 4, atan(sqrt(2)));

        new Timer(17, (ActionEvent e) -> {
            rotateCube(PI / 180, 0);
            repaint();
        }).start();
    }

    final void scale(double s) {
        for (double[] node : nodes) {
            node[0] *= s;
            node[1] *= s;
            node[2] *= s;
        }
    }

    final void rotateCube(double angleX, double angleY) {
        double sinX = sin(angleX);
        double cosX = cos(angleX);

        double sinY = sin(angleY);
        double cosY = cos(angleY);

        for (double[] node : nodes) {
            double x = node[0];
            double y = node[1];
            double z = node[2];

            node[0] = x * cosX - z * sinX;
            node[2] = z * cosX + x * sinX;

            z = node[2];

            node[1] = y * cosY - z * sinY;
            node[2] = z * cosY + y * sinY;
        }
    }

    void drawCube(Graphics2D g) {
        g.translate(getWidth() / 2, getHeight() / 2);

        for (int[] edge : edges) {
            double[] xy1 = nodes[edge[0]];
            double[] xy2 = nodes[edge[1]];
            g.drawLine((int) round(xy1[0]), (int) round(xy1[1]),
                    (int) round(xy2[0]), (int) round(xy2[1]));
        }

        for (double[] node : nodes)
            g.fillOval((int) round(node[0]) - 4, (int) round(node[1]) - 4, 8, 8);
    }

    @Override
    public void paintComponent(Graphics gg) {
        super.paintComponent(gg);
        Graphics2D g = (Graphics2D) gg;
        g.setRenderingHint(RenderingHints.KEY_ANTIALIASING,
                RenderingHints.VALUE_ANTIALIAS_ON);

        drawCube(g);
    }

    public static void main(String[] args) {
        SwingUtilities.invokeLater(() -> {
            JFrame f = new JFrame();
            f.setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE);
            f.setTitle("Rotating Cube");
            f.setResizable(false);
            f.add(new RotatingCube(), BorderLayout.CENTER);
            f.pack();
            f.setLocationRelativeTo(null);
            f.setVisible(true);
        });
    }
}


<!DOCTYPE html>
<html lang="en">
<head>
    <meta charset="UTF-8">
    <style>
        canvas {
            background-color: black;
        }
    </style>
</head>
<body>
    <canvas></canvas>
    <script>
        var canvas = document.querySelector("canvas");
        canvas.width = window.innerWidth;
        canvas.height = window.innerHeight;

        var g = canvas.getContext("2d");

        var nodes = [[-1, -1, -1], [-1, -1, 1], [-1, 1, -1], [-1, 1, 1],
        [1, -1, -1], [1, -1, 1], [1, 1, -1], [1, 1, 1]];

        var edges = [[0, 1], [1, 3], [3, 2], [2, 0], [4, 5], [5, 7], [7, 6],
        [6, 4], [0, 4], [1, 5], [2, 6], [3, 7]];

        function scale(factor0, factor1, factor2) {
            nodes.forEach(function (node) {
                node[0] *= factor0;
                node[1] *= factor1;
                node[2] *= factor2;
            });
        }

        function rotateCuboid(angleX, angleY) {

            var sinX = Math.sin(angleX);
            var cosX = Math.cos(angleX);

            var sinY = Math.sin(angleY);
            var cosY = Math.cos(angleY);

            nodes.forEach(function (node) {
                var x = node[0];
                var y = node[1];
                var z = node[2];

                node[0] = x * cosX - z * sinX;
                node[2] = z * cosX + x * sinX;

                z = node[2];

                node[1] = y * cosY - z * sinY;
                node[2] = z * cosY + y * sinY;
            });
        }

        function drawCuboid() {
            g.save();

            g.clearRect(0, 0, canvas.width, canvas.height);
            g.translate(canvas.width / 2, canvas.height / 2);
            g.strokeStyle = "#FFFFFF";
            g.beginPath();

            edges.forEach(function (edge) {
                var p1 = nodes[edge[0]];
                var p2 = nodes[edge[1]];
                g.moveTo(p1[0], p1[1]);
                g.lineTo(p2[0], p2[1]);
            });

            g.closePath();
            g.stroke();

            g.restore();
        }

        scale(200, 200, 200);
        rotateCuboid(Math.PI / 4, Math.atan(Math.sqrt(2)));

        setInterval(function() {
            rotateCuboid(Math.PI / 180, 0);
            drawCuboid();
        }, 17);

    </script>

</body>
</html>


using Makie, LinearAlgebra

N = 40
interval = 0.10

scene = mesh(FRect3D(Vec3f0(-0.5), Vec3f0(1)), color = :skyblue2)
rect = scene[end]

for rad in 0.5:1/N:8.5
    arr = normalize([cospi(rad/2), 0, sinpi(rad/2), -sinpi(rad/2)])
    Makie.rotate!(rect, Quaternionf0(arr[1], arr[2], arr[3], arr[4]))
    sleep(interval)
end


// version 1.1

import java.awt.*
import javax.swing.*

class RotatingCube : JPanel() {
    private val nodes = arrayOf(
        doubleArrayOf(-1.0, -1.0, -1.0),
        doubleArrayOf(-1.0, -1.0,  1.0),
        doubleArrayOf(-1.0,  1.0, -1.0),
        doubleArrayOf(-1.0,  1.0,  1.0),
        doubleArrayOf( 1.0, -1.0, -1.0),
        doubleArrayOf( 1.0, -1.0,  1.0),
        doubleArrayOf( 1.0,  1.0, -1.0),
        doubleArrayOf( 1.0,  1.0,  1.0)
    )
    private val edges = arrayOf(
        intArrayOf(0, 1),
        intArrayOf(1, 3),
        intArrayOf(3, 2),
        intArrayOf(2, 0),
        intArrayOf(4, 5),
        intArrayOf(5, 7),
        intArrayOf(7, 6),
        intArrayOf(6, 4),
        intArrayOf(0, 4),
        intArrayOf(1, 5),
        intArrayOf(2, 6),
        intArrayOf(3, 7)
    )

    init {
        preferredSize = Dimension(640, 640)
        background = Color.white
        scale(100.0)
        rotateCube(Math.PI / 4.0, Math.atan(Math.sqrt(2.0)))
        Timer(17) {
            rotateCube(Math.PI / 180.0, 0.0)
            repaint()
        }.start()
    }

    private fun scale(s: Double) {
        for (node in nodes) {
            node[0] *= s
            node[1] *= s
            node[2] *= s
        }
    }

    private fun rotateCube(angleX: Double, angleY: Double) {
        val sinX = Math.sin(angleX)
        val cosX = Math.cos(angleX)
        val sinY = Math.sin(angleY)
        val cosY = Math.cos(angleY)
        for (node in nodes) {
            val x = node[0]
            val y = node[1]
            var z = node[2]
            node[0] = x * cosX - z * sinX
            node[2] = z * cosX + x * sinX
            z = node[2]
            node[1] = y * cosY - z * sinY
            node[2] = z * cosY + y * sinY
        }
    }

    private fun drawCube(g: Graphics2D) {
        g.translate(width / 2, height / 2)
        for (edge in edges) {
            val xy1 = nodes[edge[0]]
            val xy2 = nodes[edge[1]]
            g.drawLine(Math.round(xy1[0]).toInt(), Math.round(xy1[1]).toInt(),
                       Math.round(xy2[0]).toInt(), Math.round(xy2[1]).toInt())
        }
        for (node in nodes) {
            g.fillOval(Math.round(node[0]).toInt() - 4, Math.round(node[1]).toInt() - 4, 8, 8)
        }
    }

    override public fun paintComponent(gg: Graphics) {
        super.paintComponent(gg)
        val g = gg as Graphics2D
        g.setRenderingHint(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON)
        g.color = Color.blue
        drawCube(g)
    }
}

fun main(args: Array<String>) {
    SwingUtilities.invokeLater {
        val f = JFrame()
        f.defaultCloseOperation = JFrame.EXIT_ON_CLOSE
        f.title = "Rotating cube"
        f.isResizable = false
        f.add(RotatingCube(), BorderLayout.CENTER)
        f.pack()
        f.setLocationRelativeTo(null)
        f.isVisible = true
    }
}


local abs,atan,cos,floor,pi,sin,sqrt = math.abs,math.atan,math.cos,math.floor,math.pi,math.sin,math.sqrt
local bitmap = {
  init = function(self, w, h, value)
    self.w, self.h, self.pixels = w, h, {}
    for y=1,h do self.pixels[y]={} end
    self:clear(value)
  end,
  clear = function(self, value)
    for y=1,self.h do
      for x=1,self.w do
        self.pixels[y][x] = value or "  "
      end
    end
  end,
  set = function(self, x, y, value)
    x,y = floor(x),floor(y)
    if x>0 and y>0 and x<=self.w and y<=self.h then
      self.pixels[y][x] = value or "#"
    end
  end,
  line = function(self, x1, y1, x2, y2, c)
    x1,y1,x2,y2 = floor(x1),floor(y1),floor(x2),floor(y2)
    local dx, sx = abs(x2-x1), x1<x2 and 1 or -1
    local dy, sy = abs(y2-y1), y1<y2 and 1 or -1
    local err = floor((dx>dy and dx or -dy)/2)
    while(true) do
      self:set(x1, y1, c)
      if (x1==x2 and y1==y2) then break end
      if (err > -dx) then
        err, x1 = err-dy, x1+sx
        if (x1==x2 and y1==y2) then
          self:set(x1, y1, c)
          break
        end
      end
      if (err < dy) then
        err, y1 = err+dx, y1+sy
      end
    end
  end,
  render = function(self)
    for y=1,self.h do
      print(table.concat(self.pixels[y]))
    end
  end,
}
screen = {
  clear = function()
    os.execute("cls") -- or? os.execute("clear"), or? io.write("\027[2J\027[H"), or etc?
  end,
}
local camera = { fl = 2.5 }
local L = 0.5
local cube = {
  verts = { {L,L,L}, {L,-L,L}, {-L,-L,L}, {-L,L,L}, {L,L,-L}, {L,-L,-L}, {-L,-L,-L}, {-L,L,-L} },
  edges = { {1,2}, {2,3}, {3,4}, {4,1}, {5,6}, {6,7}, {7,8}, {8,5}, {1,5}, {2,6}, {3,7}, {4,8} },
  rotate = function(self, rx, ry)
    local cx,sx = cos(rx),sin(rx)
    local cy,sy = cos(ry),sin(ry)
    for i,v in ipairs(self.verts) do
      local x,y,z = v[1],v[2],v[3]
      v[1], v[2], v[3] = x*cx-z*sx, y*cy-x*sx*sy-z*cx*sy, x*sx*cy+y*sy+z*cx*cy
    end
  end,
}
local renderer = {
  render = function(self, shape, camera, bitmap)
    local fl = camera.fl
    local ox, oy = bitmap.w/2, bitmap.h/2
    local mx, my = bitmap.w/2, bitmap.h/2
    local rpverts = {}
    for i,v in ipairs(shape.verts) do
      local x,y,z = v[1],v[2],v[3]
      local px = ox + mx * (fl*x)/(fl-z)
      local py = oy + my * (fl*y)/(fl-z)
      rpverts[i] = { px,py }
    end
    for i,e in ipairs(shape.edges) do
      local v1, v2 = rpverts[e[1]], rpverts[e[2]]
      bitmap:line( v1[1], v1[2], v2[1], v2[2], "██" )
    end
  end
}
--
bitmap:init(40,40)
cube:rotate(pi/4, atan(sqrt(2)))
for i=1,60 do
  cube:rotate(pi/60,0)
  bitmap:clear("··")
  renderer:render(cube, camera, bitmap)
  screen:clear()
  bitmap:render()
end


plots:-display(
    seq(
        plots:-display(
            plottools[cuboid]( [0,0,0], [1,1,1] ),
        axes=none, scaling=constrained, orientation=[0,45,i] ),
    i = 0..360, 20 ),
insequence=true );


Dynamic[
    Graphics3D[
      GeometricTransformation[
       GeometricTransformation[Cuboid[], RotationTransform[Pi/4, {1, 1, 0}]],
       RotationTransform[Clock[2 Pi], {0, 0, 1}]
      ],
      Boxed -> False]]


#~
Rotating Cube
~#

use Collection.Generic;
use Game.SDL2;
use Game.Framework;

class RotatingCube {
  # game framework
  @framework : GameFramework;
  @initialized : Bool;

  @nodes : Float[,];
  @edges : Int[,];

  New() {
    @initialized := true;
    @framework := GameFramework->New(GameConsts->SCREEN_WIDTH, GameConsts->SCREEN_HEIGHT, "Rotating Cube");

    @nodes := [[-100.0, -100.0, -100.0], [-100.0, -100.0, 100.0], [-100.0, 100.0, -100.0],
       [-100.0, 100.0, 100.0],   [100.0, -100.0, -100.0], [100.0, -100.0, 100.0],
       [100.0, 100.0, -100.0],   [100.0, 100.0, 100.0]];

        @edges := [[0, 1], [1, 3], [3, 2], [2, 0], [4, 5], [5, 7],
           [7, 6], [6, 4], [0, 4], [1, 5], [2, 6], [3, 7]];

  }

  function : Main(args : String[]) ~ Nil {
    RotatingCube->New()->Play();
  }

  method : Play() ~ Nil {
    if(@initialized) {
      # initialization
      @framework->SetClearColor(Color->New(0, 0, 0));
      RotateCube(Float->Pi(), 2.0->SquareRoot()->ArcTan());

      quit := false;
      e := @framework->GetEvent();
      while(<>quit) {
        @framework->FrameStart();
        @framework->Clear();

        # process input
        while(e->Poll() <> 0) {
          if(e->GetType() = EventType->SDL_QUIT) {
            quit := true;
          };
        };

        #draw
        DrawCube();

        @framework->FrameEnd();

        # render
        @framework->Show();

        Timer->Delay(200);

        RotateCube (Float->Pi() / 180.0, 0.0);
      };
    }
    else {
      "--- Error Initializing Environment ---"->ErrorLine();
      return;
    };

    leaving {
      @framework->FreeShapes();
    };
  }

  method : RotateCube(angleX : Float, angleY : Float) ~ Nil {
    sinX := angleX->Sin();
        cosX := angleX->Cos();

        sinY := angleY->Sin();
        cosY := angleY->Cos();

    node_sizes := @nodes->Size();
    size := node_sizes[0];

        for(i := 0; i < size; i += 1;) {
            x := @nodes[i, 0];
            y := @nodes[i, 1];
            z := @nodes[i, 2];

            @nodes[i, 0] := x * cosX - z * sinX;
            @nodes[i, 2] := z * cosX + x * sinX;

            z := @nodes[i, 2];

            @nodes[i, 1] := y * cosY - z * sinY;
            @nodes[i, 2] := z * cosY + y * sinY;
        };
  }

  method : DrawCube() ~ Nil {
    edge_sizes := @edges->Size();
    size := edge_sizes[0];

    @framework->GetRenderer()->SetDrawColor(0, 220, 0, 0);
    for(i := 0; i < size; i += 1;) {
      x0y0  := @nodes[@edges[i, 0], 0];
      x0y1  := @nodes[@edges[i, 0], 1];

      x1y0  := @nodes[@edges[i, 1], 0];
      x1y1  := @nodes[@edges[i, 1], 1];

      @framework->GetRenderer()->DrawLine(x0y0 + GameConsts->DRAW_OFFSET, x0y1 + GameConsts->DRAW_OFFSET, x1y0 + GameConsts->DRAW_OFFSET, x1y1 + GameConsts->DRAW_OFFSET);
    };
  }
}

consts GameConsts {
  SCREEN_WIDTH := 600,
  SCREEN_HEIGHT := 600,
  DRAW_OFFSET := 300
}


  % Title "Rotating Cube"
  % Animated
  % PlaceCentral
  uses ConsoleG

  sub main
  ========
  cls 0.0, 0.5, 0.7
  shading
  scale 7
  pushstate
    GoldMaterial.act
    static float ang
    rotateX ang
    rotateY ang
    go cube
  popstate
  ang+=.5 : if ang>=360 then ang-=360
  end sub

  EndScript


#!/usr/bin/perl

use strict;              # http://www.rosettacode.org/wiki/Draw_a_rotating_cube
use warnings;
use Tk;
use Time::HiRes qw( time );

my $size = 600;
my $wait = int 1000 / 30;
my ($height, $width) = ($size, $size * sqrt 8/9);
my $mid = $width / 2;
my $rot = atan2(0, -1) / 3;                   # middle corners every 60 degrees

my $mw = MainWindow->new;
my $c = $mw->Canvas(-width => $width, -height => $height)->pack;
$c->Tk::bind('<ButtonRelease>' => sub {$mw->destroy});          # click to exit
draw();
MainLoop;

sub draw
  {
  my $angle = time - $^T;                    # full rotation every 2*PI seconds
  my @points = map { $mid + $mid * cos $angle + $_ * $rot,
    $height * ($_ % 2 + 1) / 3 } 0 .. 5;
  $c->delete('all');
  $c->createLine( @points[-12 .. 1], $mid, 0, -width => 5,);
  $c->createLine( @points[4, 5], $mid, 0, @points[8, 9], -width => 5,);
  $c->createLine( @points[2, 3], $mid, $height, @points[6, 7], -width => 5,);
  $c->createLine( $mid, $height, @points[10, 11], -width => 5,);
  $mw->after($wait, \&draw);
  }


--
-- demo\rosetta\DrawRotatingCube.exw
-- =================================
--
-- credits: http://petercollingridge.appspot.com/3D-tutorial/rotating-objects
--          https://github.com/ssloy/tinyrenderer/wiki/Lesson-4:-Perspective-projection
--
-- Aside: low CPU usage, at least when using a 30ms timer (33 FPS, which is plenty).
--
with javascript_semantics
include pGUI.e

constant title = "Draw a Rotating Cube"
Ihandle dlg, canvas
cdCanvas cd_canvas

--
-- First, define 8 corners equidistant from {0,0,0}:
--
--          6-----2
--      5-----1   3
--      8-----4
--
-- ie the right face is 1-2-3-4 clockwise, and the left face
--  is 5-6-7-8 counter-clockwise (unless using x-ray vision).
-- (since this is not drawing textures, clockwise-ness does
--  not matter, as shown by the corrected orange face, but
--  it will if you (figure out how to) apply any textures.)
-- (a quick (online) study of opengl texture documentation
--  should convince you that stuff is best left to opengl.)
--
enum X, Y, Z
constant l = 100
constant corners = {{+l,+l,+l},     -- 1 (front top right)
                    {+l,+l,-l},     -- 2 (back top "right")
                    {+l,-l,-l},     -- 3 (back btm "right")
                    {+l,-l,+l},     -- 4 (front btm right)
                    {-l,+l,+l},     -- 5 (front top left)
                    {-l,+l,-l},     -- 6 (back top "left")
                    {-l,-l,-l},     -- 7 (back btm "left")
                    {-l,-l,+l}}     -- 8 (front btm left)
-- I put left/right in quotes for the back face as a reminder
-- those match the above diagram, but of course they would be
-- swapped were you looking "at" the face/rotated it by 180.

constant faces = {{CD_RED,          1,2,3,4},   -- right
                  {CD_YELLOW,       1,5,6,2},   -- top
                  {CD_DARK_GREEN,   1,4,8,5},   -- front
                  {CD_BLUE,         2,3,7,6},   -- back
                  {CD_WHITE,        3,4,8,7},   -- bottom
--                {CD_ORANGE,       5,6,7,8}}   -- left
                  {CD_ORANGE,       8,7,6,5}}   -- left

-- rotation angles, 0..359, on a timer
atom rx = 45,   -- initially makes cube like a H
     ry = 35,   --     "	   "    "	italic H
     rz = 0

constant naxes = {{Y,Z},    -- (rotate about the X-axis)
                  {X,Z},    -- (rotate about the Y-axis)
                  {X,Y}}    -- (rotate about the Z-axis)

function rotate(sequence points, atom angle, integer axis)
--
-- rotate points by the specified angle about the given axis
--
    atom radians = angle*CD_DEG2RAD,
         sin_t = sin(radians),
         cos_t = cos(radians)
    integer {nx,ny} = naxes[axis]
    for i=1 to length(points) do
        atom x = points[i][nx],
             y = points[i][ny]
        points[i][nx] = x*cos_t - y*sin_t
        points[i][ny] = y*cos_t + x*sin_t
    end for
    return points
end function

function projection(sequence points, atom d)
--
-- project points from {0,0,d} onto the perpendicular plane through {0,0,0}
--
    for i=1 to length(points) do
        atom {x,y,z} = points[i],
             denom = (1-z/d)
        points[i][X] = x/denom
        points[i][Y] = y/denom
    end for
    return points
end function

function nearest(sequence points)
--
-- return the index of the nearest point (highest z value)
--
    return largest(vslice(points,Z),true)
end function

procedure draw_cube(integer cx, cy)
    -- {cx,cy} is the centre point of the canvas
    sequence points = deep_copy(corners)
    points = rotate(points,rx,X)
    points = rotate(points,ry,Y)
    points = rotate(points,rz,Z)
    points = projection(points,1000)
    integer np = nearest(points)
    --
    -- find the three faces that contain the nearest point,
    -- then for each of those faces let diag be the point
    -- that is diagonally opposite said nearest point, and
    -- order by/draw those faces furthest diag away first.
    --  (one or two of them may be completely obscured due
    --   to the effects of the perspective projection.)
    --  (you could of course draw all six faces, as long as
    --   the 3 furthest are draw first/obliterated, which
    --   is what that commented-out "else" would achieve.)
    --
    sequence faceset = {}
    for i=1 to length(faces) do
        sequence fi = faces[i]
        integer k = find(np,fi)       -- k:=2..5, or 0
        if k then
            integer diag = mod(k,4)+2 -- {2,3,4,5} --> {4,5,2,3}
                                      -- aka swap 2<=>4 & 3<=>5
            diag = fi[diag] -- 1..8, diagonally opp. np
            faceset = append(faceset,{points[diag][Z],i})
--      else
--          faceset = append(faceset,{-9999,i})
        end if
    end for
    faceset = sort(faceset)
    for i=1 to length(faceset) do
        sequence face = faces[faceset[i][2]]
        cdCanvasSetForeground(cd_canvas,face[1])
        -- first fill sides (with bresenham edges), then
        -- redraw edges, but anti-aliased aka smoother
        sequence modes = {CD_FILL,CD_CLOSED_LINES}
        for m=1 to length(modes) do
            cdCanvasBegin(cd_canvas,modes[m])
            for fdx=2 to 5 do
                sequence pt = points[face[fdx]]
                cdCanvasVertex(cd_canvas,cx+pt[X],cy-pt[Y])
            end for
            cdCanvasEnd(cd_canvas)
        end for
    end for
end procedure

function canvas_action_cb(Ihandle canvas)
    cdCanvasActivate(cd_canvas)
    cdCanvasClear(cd_canvas)
    integer {w, h} = IupGetIntInt(canvas, "DRAWSIZE")
    draw_cube(floor(w/2),floor(h/2))
    cdCanvasFlush(cd_canvas)
    return IUP_DEFAULT
end function

function canvas_map_cb(Ihandle canvas)
    IupGLMakeCurrent(canvas)
    if platform()=JS then
        cd_canvas = cdCreateCanvas(CD_IUP, canvas)
    else
        atom res = IupGetDouble(NULL, "SCREENDPI")/25.4
        cd_canvas = cdCreateCanvas(CD_GL, "10x10 %g", {res})
    end if
    cdCanvasSetBackground(cd_canvas, CD_PARCHMENT)
    return IUP_DEFAULT
end function

function canvas_resize_cb(Ihandle /*canvas*/)
    integer {canvas_width, canvas_height} = IupGetIntInt(canvas, "DRAWSIZE")
    atom res = IupGetDouble(NULL, "SCREENDPI")/25.4
    cdCanvasSetAttribute(cd_canvas, "SIZE", "%dx%d %g", {canvas_width, canvas_height, res})
    return IUP_DEFAULT
end function

function timer_cb(Ihandln /*ih*/)
    -- (feel free to add a bit more randomness here, maybe)
    rx = mod(rx+359,360)
    ry = mod(ry+359,360)
    rz = mod(rz+359,360)
    IupRedraw(canvas)
    return IUP_IGNORE
end function

procedure main()
    IupOpen()
    canvas = IupGLCanvas("RASTERSIZE=640x480")
    IupSetCallbacks(canvas, {"ACTION", Icallback("canvas_action_cb"),
                             "MAP_CB", Icallback("canvas_map_cb"),
                             "RESIZE_CB", Icallback("canvas_resize_cb")})
    dlg = IupDialog(canvas,`TITLE="%s"`,{title})
    IupShow(dlg)
    IupSetAttribute(canvas, "RASTERSIZE", NULL)
    Ihandle hTimer = IupTimer(Icallback("timer_cb"), 30)
    if platform()!=JS then
        IupMainLoop()
        IupClose()
    end if
end procedure

main()


%!PS-Adobe-3.0
%%BoundingBox: 0 0 400 400

/ed { exch def } def
/roty { dup sin /s ed cos /c ed [[c 0 s neg] [0 1 0] [s 0 c]] } def
/rotz { dup sin /s ed cos /c ed [[c s neg 0] [s c 0] [0 0 1]] } def
/dot { /a ed /b ed
	a 0 get b 0 get mul
	a 1 get b 1 get mul
	a 2 get b 2 get mul
	add add } def

/mmul {	/v ed [exch {v dot} forall] } def
/transall { /m ed [exch {m exch mmul}forall] } def

/vt
	[[1  1  1] [-1  1  1]
	 [1 -1  1] [-1 -1  1]
	 [1  1 -1] [-1  1 -1]
	 [1 -1 -1] [-1 -1 -1]]
	-45 roty transall
	2 sqrt 1 atan rotz transall
def

/xy { exch get {} forall pop } def
/page {
	/a ed /v vt a roty transall def
	0 setlinewidth 100 100 scale 2 2 translate
	/edge { v xy moveto v xy lineto stroke } def

	0 1 2 3 4 5 6 7 0 2 1 3 4 6 5 7 0 4 1 5 2 6 3 7
	1 1 12 { pop edge } for
	showpage
} def

0 {3.2 add dup page } loop
%%EOF


void setup() {
  size(500, 500, P3D);
}
void draw() {
  background(0);
  // position
  translate(width/2, height/2, -width/2);
  // optional fill and lighting colors
  noStroke();
  strokeWeight(4);
  fill(192, 255, 192);
  pointLight(255, 255, 255, 0, -500, 500);
  // rotation driven by built-in timer
  rotateY(millis()/1000.0);
  // draw box
  box(300, 300, 300);
}


from visual import *
scene.title = "VPython: Draw a rotating cube"

scene.range = 2
scene.autocenter = True

print "Drag with right mousebutton to rotate view."
print "Drag up+down with middle mousebutton to zoom."

deg45 = math.radians(45.0)  # 0.785398163397

cube = box()    # using defaults, see http://www.vpython.org/contents/docs/defaults.html
cube.rotate( angle=deg45, axis=(1,0,0) )
cube.rotate( angle=deg45, axis=(0,0,1) )

while True:                 # Animation-loop
    rate(50)
    cube.rotate( angle=0.005, axis=(0,1,0) )


#lang racket/gui
(require math/matrix math/array)

(define (Rx θ)
  (matrix [[1.0    0.0        0.0]
           [0.0 (cos θ) (- (sin θ))]
           [0.0 (sin θ)    (cos θ)]]))

(define (Ry θ)
  (matrix [[   (cos θ)  0.0 (sin θ)]
           [      0.0   1.0    0.0 ]
           [(- (sin θ)) 0.0 (cos θ)]]))

(define (Rz θ)
  (matrix [[(cos θ) (- (sin θ)) 0.0]
           [(sin θ)    (cos θ)  0.0]
           [   0.0        0.0   1.0]]))

(define base-matrix
  (matrix* (identity-matrix 3 100.0)
           (Rx (- (/ pi 2) (atan (sqrt 2))))
           (Rz (/ pi 4.0))))

(define (current-matrix)
  (matrix* (Ry (/ (current-inexact-milliseconds) 1000.))
           base-matrix))

(define corners
  (for*/list ([x '(-1.0 1.0)]
              [y '(-1.0 1.0)]
              [z '(-1.0 1.0)])
    (matrix [[x] [y] [z]])))

(define lines
  '((0 1) (0 2) (0 4) (1 3) (1 5)
    (2 3) (2 6) (3 7) (4 5) (4 6)
    (5 7) (6 7)))

(define ox 200.)
(define oy 200.)

(define (draw-line dc a b)
  (send dc draw-line
        (+ ox (array-ref a #(0 0)))
        (+ oy (array-ref a #(1 0)))
        (+ ox (array-ref b #(0 0)))
        (+ oy (array-ref b #(1 0)))))

(define (draw-cube c dc)
  (define-values (w h) (send dc get-size))
  (set! ox (/ w 2))
  (set! oy (/ h 2))
  (define cs (for/vector ([c (in-list corners)])
               (matrix* (current-matrix) c)))
  (for ([l (in-list lines)])
    (match-define (list i j) l)
    (draw-line dc (vector-ref cs i) (vector-ref cs j))))

(define f (new frame%  [label "cube"]))
(define c (new canvas% [parent f] [min-width 400] [min-height 400] [paint-callback draw-cube]))
(send f show #t)

(send* (send c get-dc)
  (set-pen "black" 1 'solid)
  (set-smoothing 'smoothed))

(define (refresh)
  (send c refresh))

(define t (new timer% [notify-callback refresh] [interval 35] [just-once? #f]))


use Terminal::Caca;
given my $canvas = Terminal::Caca.new {
    .title('Rosetta Code - Rotating cube - Press any key to exit');

    sub scale-and-translate($x, $y, $z) {
        $x * 5 / ( 5 + $z ) * 15 + 40,
        $y * 5 / ( 5 + $z ) *  7 + 15,
        $z;
    }

    sub rotate3d-x( $x, $y, $z, $angle ) {
        my ($cosθ, $sinθ) = cis( $angle * π / 180.0 ).reals;
        $x,
        $y * $cosθ - $z * $sinθ,
        $y * $sinθ + $z * $cosθ;
    }

    sub rotate3d-y( $x, $y, $z, $angle ) {
        my ($cosθ, $sinθ) = cis( $angle * π / 180.0 ).reals;
        $x * $cosθ - $z * $sinθ,
        $y,
        $x * $sinθ + $z * $cosθ;
    }

    sub rotate3d-z( $x, $y, $z, $angle ) {
        my ($cosθ, $sinθ) = cis( $angle * π / 180.0 ).reals;
        $x * $cosθ - $y * $sinθ,
        $x * $cosθ + $y * $sinθ,
        $z;
    }

    # Unit cube from polygon mesh, aligned to axes
    my @mesh =
      [ [1, 1, -1], [-1, -1, -1], [-1,  1, -1] ], # far face
      [ [1, 1, -1], [-1, -1, -1], [ 1, -1, -1] ],
      [ [1, 1,  1], [-1, -1,  1], [-1,  1,  1] ], # near face
      [ [1, 1,  1], [-1, -1,  1], [ 1, -1,  1] ];
      @mesh.push: [$_».rotate( 1)».Array] for @mesh[^4]; # positive and
      @mesh.push: [$_».rotate(-1)».Array] for @mesh[^4]; # negative rotations

    # Rotate to correct orientation for task
    for ^@mesh X ^@mesh[0] -> ($i, $j) {
        @(@mesh[$i;$j]) = rotate3d-x |@mesh[$i;$j], 45;
        @(@mesh[$i;$j]) = rotate3d-z |@mesh[$i;$j], 40;
    }

    my @colors = red, blue, green, cyan, magenta, yellow;

    loop {
        for ^359 -> $angle {
            .color( white, white );
            .clear;

            # Flatten 3D into 2D and rotate for all faces
            my @faces-z;
            my $c-index = 0;
            for @mesh -> @triangle {
                my @points;
                my $sum-z = 0;
                for @triangle -> @node {
                    my ($px, $py, $z) = scale-and-translate |rotate3d-y |@node, $angle;
                    @points.append: $px.Int, $py.Int;
                    $sum-z += $z;
                }

                @faces-z.push: %(
                    color  => @colors[$c-index++ div 2],
                    points => @points,
                    avg-z  => $sum-z / +@points;
                );
            }

            # Draw all faces
            # Sort by z to draw farthest first
            for @faces-z.sort( -*.<avg-z> ) -> %face {
                # Draw filled triangle
                .color( %face<color>, %face<color> );
                .fill-triangle( |%face<points> );
                # And frame
                .color( black, black );
                .thin-triangle( |%face<points> );
            }

            .refresh;
            exit if .wait-for-event(key-press);
        }
    }

    # Cleanup on scope exit
    LEAVE {
        .cleanup;
    }
}


#===================================================================#
# Based on Original Sample from RayLib (https://www.raylib.com/)
# Ported to RingRayLib by Ring Team
#===================================================================#

load "raylib.ring"

screenWidth = 800
screenHeight = 450

InitWindow(screenWidth, screenHeight, "raylib [core] example - 3d picking")

camera = Camera3D(
	10, 10, 10,
	0, 0, 0 ,
	0, 1, 0 ,
	45,
	CAMERA_PERSPECTIVE
)

cubePosition = Vector3( 0, 1, 0 )
cubeSize = Vector3( 2, 2, 2 )

ray = Ray(0,0,0,0,0,0)

collision = false

SetCameraMode(camera, CAMERA_FREE)

SetTargetFPS(60)

while !WindowShouldClose()

        UpdateCamera(camera)

        if IsMouseButtonPressed(MOUSE_LEFT_BUTTON)
            if !collision
                ray = GetMouseRay(GetMousePosition(), camera)

                collision = CheckCollisionRayBox(ray,
 		BoundingBox( cubePosition.x - cubeSize.x/2, cubePosition.y - cubeSize.y/2, cubePosition.z - cubeSize.z/2,
    		cubePosition.x + cubeSize.x/2, cubePosition.y + cubeSize.y/2, cubePosition.z + cubeSize.z/2 ) )
            else collision = false
 	    ok
	ok

        BeginDrawing()

            ClearBackground(RAYWHITE)

            BeginMode3D(camera)

                if collision
                    DrawCube(cubePosition, cubeSize.x, cubeSize.y, cubeSize.z, RED)
                    DrawCubeWires(cubePosition, cubeSize.x, cubeSize.y, cubeSize.z, MAROON)

                    DrawCubeWires(cubePosition, cubeSize.x + 0.2f, cubeSize.y + 0.2f, cubeSize.z + 0.2f, GREEN)
                else
                    DrawCube(cubePosition, cubeSize.x, cubeSize.y, cubeSize.z, GRAY)
                    DrawCubeWires(cubePosition, cubeSize.x, cubeSize.y, cubeSize.z, DARKGRAY)
                ok

                DrawRay(ray, MAROON)
                DrawGrid(10, 1)

            EndMode3D()

            DrawText("Try selecting the box with mouse!", 240, 10, 20, DARKGRAY)

            if collision  DrawText("BOX SELECTED", (screenWidth - MeasureText("BOX SELECTED", 30)) / 2, screenHeight * 0.1f, 30, GREEN) ok

            DrawFPS(10, 10)

        EndDrawing()
end

CloseWindow()


import java.awt.event.ActionEvent
import java.awt._

import javax.swing.{JFrame, JPanel, Timer}

import scala.math.{Pi, atan, cos, sin, sqrt}

object RotatingCube extends App {

  class RotatingCube extends JPanel {
    private val vertices: Vector[Array[Double]] =
      Vector(Array(-1, -1, -1), Array(-1, -1, 1), Array(-1, 1, -1),
        Array(-1, 1, 1), Array(1, -1, -1), Array(1, -1, 1), Array(1, 1, -1), Array(1, 1, 1))

    private val edges: Vector[(Int, Int)] =
      Vector((0, 1), (1, 3), (3, 2), (2, 0), (4, 5), (5, 7),
        (7, 6), (6, 4), (0, 4), (1, 5), (2, 6), (3, 7))

    setPreferredSize(new Dimension(640, 640))
    setBackground(Color.white)
    scale(100)
    rotateCube(Pi / 4, atan(sqrt(2)))

    new Timer(17, (_: ActionEvent) => {
      rotateCube(Pi / 180, 0)
      repaint()
    }).start()

    override def paintComponent(gg: Graphics): Unit = {
      def drawCube(g: Graphics2D): Unit = {
        g.translate(getWidth / 2, getHeight / 2)
        for {edge <- edges
             xy1: Array[Double] = vertices(edge._1)
             xy2: Array[Double] = vertices(edge._2)
             } {
          g.drawLine(xy1(0).toInt, xy1(1).toInt, xy2(0).toInt, xy2(1).toInt)
          g.fillOval(xy1(0).toInt -4, xy1(1).toInt - 4, 8, 8)
          g.setColor(Color.black)
        }
      }

      super.paintComponent(gg)
      val g: Graphics2D = gg.asInstanceOf[Graphics2D]
      g.setRenderingHint(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON)
      drawCube(g)
    }

    private def scale(s: Double): Unit = {
      for {node <- vertices
           i <- node.indices
           } node(i) *= s
    }

    private def rotateCube(angleX: Double, angleY: Double): Unit = {
      def sinCos(x: Double) = (sin(x), cos(x))

      val ((sinX, cosX), (sinY, cosY)) = (sinCos(angleX), sinCos(angleY))

      for {
        node <- vertices
        x: Double = node(0)
        y: Double = node(1)
      } {
        def f(p: Double, q: Double)(a: Double, b: Double) = a * p + b * q

        def fx(a: Double, b: Double) = f(cosX, sinX)(a, b)

        def fy(a: Double, b: Double) = f(cosY, sinY)(a, b)

        node(0) = fx(x, -node(2))
        val z = fx(node(2), x)
        node(1) = fy(y, -z)
        node(2) = fy(z, y)
      }
    }

  }

  new JFrame("Rotating Cube") {
    add(new RotatingCube(), BorderLayout.CENTER)
    pack()
    setDefaultCloseOperation(javax.swing.WindowConstants.EXIT_ON_CLOSE)
    setLocationRelativeTo(null)
    setResizable(false)
    setVisible(true)
  }

}


# matrix operation support:
package require math::linearalgebra
namespace import ::math::linearalgebra::matmul
namespace import ::math::linearalgebra::crossproduct
namespace import ::math::linearalgebra::dotproduct
namespace import ::math::linearalgebra::sub

# returns a cube as a list of faces,
# where each face is a list of (3space) points
proc make_cube {{radius 1}} {
    set dirs {
        A { 1  1  1}
        B { 1  1 -1}
        C { 1 -1 -1}
        D { 1 -1  1}
        E {-1  1  1}
        F {-1  1 -1}
        G {-1 -1 -1}
        H {-1 -1  1}
    }
    set faces {
        {A B C D}
        {D C G H}
        {H G F E}
        {E F B A}
        {A D H E}
        {C B F G}
    }
    lmap fa $faces {
        lmap dir $fa {
            lmap x [dict get $dirs $dir] {
                expr {1.0 * $x * $radius}
            }
        }
    }
}

# a matrix constructor
proc Matrix {m} {
    tailcall lmap row $m {
        lmap e $row {
            expr 1.0*($e)
        }
    }
}

proc identity {} {
    Matrix {
        {1 0 0}
        {0 1 0}
        {0 0 1}
    }
}

# some matrices useful for animation:
proc rotateZ {theta} {
    Matrix {
        { cos($theta) -sin($theta)  0 }
        { sin($theta)  cos($theta)  0 }
        { 0            0            1 }
    }
}
proc rotateY {theta} {
    Matrix {
        { sin($theta)  0  cos($theta) }
        { 0            1            0 }
        { cos($theta)  0 -sin($theta) }
    }
}
proc rotateX {theta} {
    Matrix {
        { 1            0            0 }
        { 0  cos($theta) -sin($theta) }
        { 0  sin($theta)  cos($theta) }
    }
}

proc camera {flen} {
    Matrix {
        { $flen  0      0 }
        { 0      $flen  0 }
        { 0      0      0 }
    }
}

proc render {canvas object} {

    set W   [winfo width  $canvas]
    set H   [winfo height $canvas]

    set fl  1.0
    set t   [expr {[clock microseconds] / 1000000.0}]

    set transform [identity]
    set transform [matmul $transform [rotateX [expr {atan(1)}]]]
    set transform [matmul $transform [rotateZ [expr {atan(1)}]]]

    set transform [matmul $transform [rotateY $t]]
    set transform [matmul $transform [camera $fl]]

    foreach face $object {
        # do transformations into screen space:
        set points [lmap p $face { matmul $p $transform }]
        # calculate a normal
        set o       [lindex $points 0]
        set v1 [sub [lindex $points 1] $o]
        set v2 [sub [lindex $points 2] $o]
        set normal [crossproduct $v1 $v2]

        set cosi   [dotproduct $normal {0 0 -1.0}]
        if {$cosi <= 0} { ;# rear-facing!
            continue
        }

        set points [lmap p $points {
            lassign $p x y
            list [expr {$x + $W/2}] [expr {$y + $H/2}]
        }]
        set points [concat {*}$points]
        $canvas create poly $points -outline black -fill red
    }
}

package require Tk
pack [canvas .c] -expand yes -fill both

proc tick {} {
    .c delete all
    render .c $::world
    after 50 tick
}
set ::world [make_cube 100]
tick


import "graphics" for Canvas, Color
import "dome" for Window
import "math" for Math

var Nodes = [
    [-1, -1, -1],
    [-1, -1,  1],
    [-1,  1, -1],
    [-1,  1,  1],
    [ 1, -1, -1],
    [ 1, -1,  1],
    [ 1,  1, -1],
    [ 1,  1,  1]
]

var Edges = [
    [0, 1],
    [1, 3],
    [3, 2],
    [2, 0],
    [4, 5],
    [5, 7],
    [7, 6],
    [6, 4],
    [0, 4],
    [1, 5],
    [2, 6],
    [3, 7]
]

class RotatingCube {
    construct new(width, height) {
        Window.title = "Rotating cube"
        Window.resize(width, height)
        Canvas.resize(width, height)
        _width = width
        _height = height
        _fore = Color.blue
    }

    init() {
        scale(100)
        rotateCube(Num.pi / 4, Math.atan(2.sqrt))
        drawCube()
    }

    update() {
        rotateCube(Num.pi / 180, 0)
    }

    draw(alpha) {
        drawCube()
    }

    scale(s) {
        for (node in Nodes) {
            node[0] = node[0] * s
            node[1] = node[1] * s
            node[2] = node[2] * s
        }
    }

    drawCube() {
        Canvas.cls(Color.white)
        Canvas.offset(_width / 2, _height / 2)
        for (edge in Edges) {
            var xy1 = Nodes[edge[0]]
            var xy2 = Nodes[edge[1]]
            Canvas.line(Math.round(xy1[0]), Math.round(xy1[1]),
                        Math.round(xy2[0]), Math.round(xy2[1]), _fore)
        }
        for (node in Nodes) {
            Canvas.rectfill(Math.round(node[0]) - 4, Math.round(node[1]) - 4, 8, 8, _fore)
        }
    }

    rotateCube(angleX, angleY) {
        var sinX = Math.sin(angleX)
        var cosX = Math.cos(angleX)
        var sinY = Math.sin(angleY)
        var cosY = Math.cos(angleY)
        for (node in Nodes) {
            var x = node[0]
            var y = node[1]
            var z = node[2]
            node[0] = x * cosX - z * sinX
            node[2] = z * cosX + x * sinX
            z = node[2]
            node[1] = y * cosY - z * sinY
            node[2] = z * cosY + y * sinY
        }
    }
}

var Game = RotatingCube.new(640, 640)


def  Size=100., Speed=0.05;             \drawing size and rotation speed
real X, Y, Z, Farthest;                 \arrays: 3D coordinates of vertices
int  I, J, K, ZI, Edge;
def  R2=sqrt(2.), R3=sqrt(3.), R13=sqrt(1./3.), R23=sqrt(2./3.), R232=R23*2.;
\vertex:0       1       2       3       4       5       6       7
[X:= [  0.,     R2,     0.,    -R2,     0.,     R2,     0.,    -R2];
 Y:= [ -R3,    -R13,    R13,   -R13,   -R13,    R13,    R3,     R13];
 Z:= [  0.,    -R23,   -R232,  -R23,    R232,   R23,    0.,     R23];
Edge:= [0,1, 1,2, 2,3, 3,0, 4,5, 5,6, 6,7, 7,4, 0,4, 1,5, 2,6, 3,7];
SetVid($101);                           \set 640x480x8 graphics
repeat  Farthest:= 0.0;                 \find the farthest vertex
        for I:= 0 to 8-1 do
            if Z(I) > Farthest then [Farthest:= Z(I);  ZI:= I];
        Clear;                          \erase screen
        for I:= 0 to 2*12-1 do          \for all the vertices...
            [J:= Edge(I);  I:= I+1;     \get vertex numbers for edge
            Move(Fix(X(J)*Size)+640/2, Fix(Y(J)*Size)+480/2);
            K:= Edge(I);
            Line(Fix(X(K)*Size)+640/2, Fix(Y(K)*Size)+480/2,
                if J=ZI ! K=ZI then $F001 \dashed blue\ else $0C \red\);
            ];
        DelayUS(55000);
        for I:= 0 to 8-1 do
            [X(I):= X(I) + Z(I)*Speed;  \rotate vertices about Y axis
             Z(I):= Z(I) - X(I)*Speed;  \ (which rotates in X-Z plane)
            ];
until KeyHit;                           \run until a key is struck
SetVid(3);                              \restore normal text mode
]


with Ada.Containers.Doubly_Linked_Lists;
with Ada.Text_IO;

procedure Traversing is
   package Char_Lists is new Ada.Containers.Doubly_Linked_Lists (Character);

   procedure Print (Position : in Char_Lists.Cursor) is
   begin
      Ada.Text_IO.Put (Char_Lists.Element (Position));
   end Print;

   My_List : Char_Lists.List;
begin
   My_List.Append ('R');
   My_List.Append ('o');
   My_List.Append ('s');
   My_List.Append ('e');
   My_List.Append ('t');
   My_List.Append ('t');
   My_List.Append ('a');

   My_List.Iterate (Print'Access);
   Ada.Text_IO.New_Line;

   My_List.Reverse_Iterate (Print'Access);
   Ada.Text_IO.New_Line;
end Traversing;


# Node struct - contains next and prev NODE pointers and DATA #
MODE NODE = STRUCT(
    DATA data,
    REF NODE prev,
    REF NODE next
    );

# List structure - contains head and tail NODE pointers #
MODE LIST = STRUCT(
    REF NODE head,
    REF NODE tail
    );

# --- PREPEND - Adds a node to the beginning of the list ---#
PRIO PREPEND = 1;
OP   PREPEND = (REF LIST list, DATA data) VOID:
(
    HEAP NODE n := (data, NIL, NIL);
    IF head OF list IS REF NODE(NIL) THEN
        head OF list := tail OF list := n
    ELSE
        next OF n := head OF list;
        prev OF head OF list := head OF list := n
    FI
);
#--- APPEND - Adds a node to the end of the list ---#
PRIO APPEND = 1;
OP   APPEND = (REF LIST list, DATA data) VOID:
(
    HEAP NODE n := (data, NIL, NIL);
    IF head OF list IS REF NODE(NIL) THEN
        head OF list := tail OF list := n
    ELSE
        prev OF n := tail OF list;
        next OF tail OF list := tail OF list := n
    FI
);

#--- REMOVE_FIRST - removes & returns node at end of the list ---#
PRIO REMOVE_FIRST = 1;
OP   REMOVE_FIRST = (REF LIST list) DATA:
(
    IF head OF list ISNT REF NODE(NIL) THEN
        DATA d := data OF head OF list;
        prev OF next OF head OF list := NIL;
        head OF list := next OF head OF list;
        d # return d #
    FI
);
#--- REMOVE_LAST: removes & returns node at front of list ---   #
PRIO REMOVE_LAST = 1;
OP   REMOVE_LAST = (REF LIST list) DATA:
(
    IF head OF list ISNT REF NODE(NIL) THEN
        DATA d := data OF tail OF list;
        next OF prev OF tail OF list := NIL;
        tail OF list := prev OF tail OF list;
        d # return d #
    FI
);
#--- PURGE - removes all elements from the list ---#
PRIO PURGE = 2;
OP   PURGE = (REF LIST list) VOID:
(
    head OF list := tail OF list := NIL
);

#--- returns the data at the end of the list ---#
PRIO LAST_IN = 2;
OP LAST_IN = (REF LIST list) DATA: (
    IF head OF list ISNT REF NODE(NIL) THEN
        data OF tail OF list
    FI
);

#--- returns the data at the front of the list ---#
PRIO FIRST_IN  = 2;
OP FIRST_IN = (REF LIST list) DATA: (
    IF head OF list ISNT REF NODE(NIL) THEN
        data OF head OF list
    FI
);

#--- Traverses through the list forwards ---#
PROC forward traversal = (LIST list) VOID:
(
    REF NODE travel := head OF list;
    WHILE travel ISNT REF NODE(NIL) DO
        list visit(data OF travel);
        travel := next OF travel
    OD
);

#--- Traverses through the list backwards ---#
PROC backward traversal = (LIST list) VOID:
(
    REF NODE travel := tail OF list;
    WHILE travel ISNT REF NODE(NIL) DO
        list visit(data OF travel);
        travel := prev OF travel
    OD
)


begin
    % record type to hold an element of a doubly linked list of integers      %
    record DListIElement ( reference(DListIElement) prev
                         ; integer iValue
                         ; reference(DListIElement) next
                         );
    % additional record types would be required for other element types       %
    % inserts a new element into the list, before e                           %
    reference(DListIElement) procedure insertIntoDListIBefore( reference(DListIElement) value e
                                                             ; integer                  value v
                                                             );
    begin
        reference(DListIElement) newElement;
        newElement := DListIElement( null, v, e );
        if e not = null then begin
            % the element we are inserting before is not null                 %
            reference(DListIElement) ePrev;
            ePrev            := prev(e);
            prev(newElement) := ePrev;
            prev(e)          := newElement;
            if ePrev not = null then next(ePrev) := newElement
        end if_e_ne_null ;
        newElement
    end insertIntoDListiAfter ;

    begin
        reference(DListIElement) head, e, last;
        head := null;
        head := insertIntoDListIBefore( head,        1701 );
        head := insertIntoDListIBefore( head,        9000 );
        e    := insertIntoDListIBefore( next(head), 90210 );
        e    := insertIntoDListIBefore( next(e),     4077 );
        e    := head;
        last := null;
        write( "Forward:" );
        while e not = null do begin
            write( i_w := 1, s_w := 0, " ", iValue(e) );
            last := e;
            e    := next(e)
        end while_e_ne_null ;
        write( "Backward:" );
        e := last;
        while e not = null do begin
            write( i_w := 1, s_w := 0, " ", iValue(e) );
            last := e;
            e    := prev(e)
        end while_e_ne_null
    end
end.


/* ARM assembly Raspberry PI  */
/*  program transDblList.s   */
/* REMARK 1 : this program use routines in a include file
   see task Include a file language arm assembly
   for the routine affichageMess conversion10S
   see at end of this program the instruction include */

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

/*******************************************/
/* Structures                               */
/********************************************/
/* structure Doublylinkedlist*/
    .struct  0
dllist_head:                    @ head node
    .struct  dllist_head + 4
dllist_tail:                    @ tail node
    .struct  dllist_tail  + 4
dllist_fin:
/* structure Node Doublylinked List*/
    .struct  0
NDlist_next:                    @ next element
    .struct  NDlist_next + 4
NDlist_prev:                    @ previous element
    .struct  NDlist_prev + 4
NDlist_value:                   @ element value or key
    .struct  NDlist_value + 4
NDlist_fin:
/* Initialized data */
.data
szMessInitListe:         .asciz "List initialized.\n"
szMessListInv:           .asciz "Display list inverse :\n"
szCarriageReturn:        .asciz "\n"
szMessErreur:            .asciz "Error detected.\n"
/* datas message display */
szMessResult:            .ascii "Result value :"
sValue:                  .space 12,' '
                         .asciz "\n"
/* UnInitialized data */
.bss
dllist1:              .skip dllist_fin    @ list memory place

/*  code section */
.text
.global main
main:
    ldr r0,iAdrdllist1
    bl newDList                      @ create new list
    ldr r0,iAdrszMessInitListe
    bl affichageMess
    ldr r0,iAdrdllist1               @ list address
    mov r1,#10                       @ value
    bl insertHead                    @ insertion at head
    cmp r0,#-1
    beq 99f
    ldr r0,iAdrdllist1
    mov r1,#20
    bl insertTail                    @ insertion at tail
    cmp r0,#-1
    beq 99f
    ldr r0,iAdrdllist1               @ list address
    mov r1,#10                       @ value to after insered
    mov r2,#15                       @ new value
    bl insertAfter
    cmp r0,#-1
    beq 99f
    ldr r0,iAdrdllist1               @ list address
    mov r1,#20                       @ value to after insered
    mov r2,#25                       @ new value
    bl insertAfter
    cmp r0,#-1
    beq 99f
    ldr r0,iAdrdllist1
    bl transHeadTail                 @ display value head to tail
    ldr r0,iAdrszMessListInv
    bl affichageMess
    ldr r0,iAdrdllist1
    bl transTailHead                 @ display value tail to head
    b 100f
99:
    ldr r0,iAdrszMessErreur
    bl affichageMess
100:                                 @ standard end of the program
    mov r7, #EXIT                    @ request to exit program
    svc 0                            @ perform system call
iAdrszMessInitListe:       .int szMessInitListe
iAdrszMessErreur:          .int szMessErreur
iAdrszMessListInv:         .int szMessListInv
iAdrszCarriageReturn:      .int szCarriageReturn
iAdrdllist1:               .int dllist1
/******************************************************************/
/*     create new list                         */
/******************************************************************/
/* r0 contains the address of the list structure */
newDList:
    push {r1,lr}                         @ save  registers
    mov r1,#0
    str r1,[r0,#dllist_tail]
    str r1,[r0,#dllist_head]
    pop {r1,lr}                          @ restaur registers
    bx lr                                @ return
/******************************************************************/
/*     list is empty ?                         */
/******************************************************************/
/* r0 contains the address of the list structure */
/* r0 return 0 if empty  else return 1 */
isEmpty:
    //push {r1,lr}                         @ save  registers
    ldr r0,[r0,#dllist_head]
    cmp r0,#0
    movne r0,#1
    //pop {r1,lr}                          @ restaur registers
    bx lr                                @ return
/******************************************************************/
/*     insert value at list head                        */
/******************************************************************/
/* r0 contains the address of the list structure */
/* r1 contains value */
insertHead:
    push {r1-r4,lr}                         @ save  registers
    mov r4,r0                            @ save address
    mov r0,r1                            @ value
    bl createNode
    cmp r0,#-1                           @ allocation error ?
    beq 100f
    ldr r2,[r4,#dllist_head]             @ load address first node
    str r2,[r0,#NDlist_next]             @ store in next pointer on new node
    mov r1,#0
    str r1,[r0,#NDlist_prev]             @ store zero in previous pointer on new node
    str r0,[r4,#dllist_head]             @ store address new node in address head list
    cmp r2,#0                            @ address first node is null ?
    strne r0,[r2,#NDlist_prev]           @ no store adresse new node in previous pointer
    streq r0,[r4,#dllist_tail]           @ else store new node in tail address
100:
    pop {r1-r4,lr}                          @ restaur registers
    bx lr                                @ return
/******************************************************************/
/*     insert value at list tail                        */
/******************************************************************/
/* r0 contains the address of the list structure */
/* r1 contains value */
insertTail:
    push {r1-r4,lr}                         @ save  registers
    mov r4,r0                               @ save list address
    mov r0,r1                               @ value
    bl createNode                           @ new node
    cmp r0,#-1
    beq 100f                                @ allocation error
    ldr r2,[r4,#dllist_tail]                @ load address last node
    str r2,[r0,#NDlist_prev]                @ store in previous pointer on new node
    mov r1,#0                               @ store null un next pointer
    str r1,[r0,#NDlist_next]
    str r0,[r4,#dllist_tail]                @ store address new node on list tail
    cmp r2,#0                               @ address last node is null ?
    strne r0,[r2,#NDlist_next]              @ no store address new node in next pointer
    streq r0,[r4,#dllist_head]              @ else store in head list
100:
    pop {r1-r4,lr}                          @ restaur registers
    bx lr                                   @ return
/******************************************************************/
/*     insert value after other element                        */
/******************************************************************/
/* r0 contains the address of the list structure */
/* r1 contains value to search*/
/* r2 contains value to insert */
insertAfter:
    push {r1-r5,lr}                         @ save  registers
    mov r4,r0
    bl searchValue                          @ search node with this value in r1
    cmp r0,#-1
    beq 100f                                @ not found -> error
    mov r5,r0                               @ save address of node find
    mov r0,r2                               @ new value
    bl createNode                           @ create new node
    cmp r0,#-1
    beq 100f                                @ allocation error
    ldr r2,[r5,#NDlist_next]                @ load pointer next of find node
    str r0,[r5,#NDlist_next]                @ store new node in pointer next
    str r5,[r0,#NDlist_prev]                @ store address find node in previous pointer on new node
    str r2,[r0,#NDlist_next]                @ store pointer next of find node on pointer next on new node
    cmp r2,#0                               @ next pointer is null ?
    strne r0,[r2,#NDlist_prev]              @ no store address new node in previous pointer
    streq r0,[r4,#dllist_tail]              @ else store in list tail
100:
    pop {r1-r5,lr}                          @ restaur registers
    bx lr                                @ return
/******************************************************************/
/*     search value                                               */
/******************************************************************/
/* r0 contains the address of the list structure */
/* r1 contains the value to search  */
/* r0 return address of node or -1 if not found */
searchValue:
    push {r2,lr}                         @ save  registers
    ldr r0,[r0,#dllist_head]             @ load first node
1:
    cmp r0,#0                            @ null -> end search not found
    moveq r0,#-1
    beq 100f
    ldr r2,[r0,#NDlist_value]            @ load node value
    cmp r2,r1                            @ equal ?
    beq 100f
    ldr r0,[r0,#NDlist_next]             @ load addresse next node
    b 1b                                 @ and loop
100:
    pop {r2,lr}                          @ restaur registers
    bx lr                                @ return
/******************************************************************/
/*     transversal for head to tail                                               */
/******************************************************************/
/* r0 contains the address of the list structure */
transHeadTail:
    push {r2,lr}                         @ save  registers
    ldr r2,[r0,#dllist_head]             @ load first node
1:
    ldr r0,[r2,#NDlist_value]
    ldr r1,iAdrsValue
    bl conversion10S
    ldr r0,iAdrszMessResult
    bl affichageMess
    ldr r2,[r2,#NDlist_next]
    cmp r2,#0
    bne 1b
100:
    pop {r2,lr}                          @ restaur registers
    bx lr                                @ return
iAdrszMessResult:          .int szMessResult
iAdrsValue:                .int sValue
/******************************************************************/
/*     transversal for tail to head                                               */
/******************************************************************/
/* r0 contains the address of the list structure */
transTailHead:
    push {r2,lr}                         @ save  registers
    ldr r2,[r0,#dllist_tail]             @ load last node
1:
    ldr r0,[r2,#NDlist_value]
    ldr r1,iAdrsValue
    bl conversion10S
    ldr r0,iAdrszMessResult
    bl affichageMess
    ldr r2,[r2,#NDlist_prev]
    cmp r2,#0
    bne 1b
100:
    pop {r2,lr}                          @ restaur registers
    bx lr                                @ return
/******************************************************************/
/*     Create new node                                            */
/******************************************************************/
/* r0 contains the value */
/* r0 return node address or -1 if allocation error*/
createNode:
    push {r1-r7,lr}                         @ save  registers
    mov r4,r0                            @ save value
    @ allocation place on the heap
    mov r0,#0                                   @ allocation place heap
    mov r7,#0x2D                                @ call system 'brk'
    svc #0
    mov r5,r0                                   @ save address heap for output string
    add r0,#NDlist_fin                            @ reservation place one element
    mov r7,#0x2D                                @ call system 'brk'
    svc #0
    cmp r0,#-1                                  @ allocation error
    beq 100f
    mov r0,r5
    str r4,[r0,#NDlist_value]                   @ store value
    mov r2,#0
    str r2,[r0,#NDlist_next]                    @ store zero to pointer next
    str r2,[r0,#NDlist_prev]                    @ store zero to pointer previous
100:
    pop {r1-r7,lr}                          @ restaur registers
    bx lr                                @ return
/***************************************************/
/*      ROUTINES INCLUDE                 */
/***************************************************/
.include "../affichage.inc"


LINK(L₁,1)→A
LINK(L₁+10,2)→B
LINK(L₁+50,3)→C

INSERT(A,B)
INSERT(A,C)

A→I
While I≠0
 Disp VALUE(I)▶Dec,i
 NEXT(I)→I
End

Disp "-----",i

B→I
While I≠0
 Disp VALUE(I)▶Dec,i
 PREV(I)→I
End


      DIM node{pPrev%, pNext%, iData%}
      DIM a{} = node{}, b{} = node{}, c{} = node{}

      a.pNext% = b{}
      a.iData% = 123
      b.pPrev% = a{}
      b.iData% = 789
      c.iData% = 456

      PROCinsert(a{}, c{})

      PRINT "Traverse forwards:"
      pnode% = a{}
      REPEAT
        !(^node{}+4) = pnode%
        PRINT node.iData%
        pnode% = node.pNext%
      UNTIL pnode% = 0

      PRINT "Traverse backwards:"
      pnode% = b{}
      REPEAT
        !(^node{}+4) = pnode%
        PRINT node.iData%
        pnode% = node.pPrev%
      UNTIL pnode% = 0

      END

      DEF PROCinsert(here{}, new{})
      LOCAL temp{} : DIM temp{} = node{}
      new.pNext% = here.pNext%
      new.pPrev% = here{}
      !(^temp{}+4) = new.pNext%
      temp.pPrev% = new{}
      here.pNext% = new{}
      ENDPROC


// A doubly linked list of strings;
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

typedef struct sListEntry {
    const char *value;
    struct sListEntry *next;
    struct sListEntry *prev;
} *ListEntry, *LinkedList;

typedef struct sListIterator{
    ListEntry  link;
    LinkedList head;
} *LIterator;

LinkedList NewList() {
    ListEntry le = malloc(sizeof(struct sListEntry));
    if (le) {
        le->value = NULL;
        le->next = le->prev = NULL;
    }
    return le;
}

int LL_Append(LinkedList ll, const char *newVal)
{
    ListEntry le = malloc(sizeof(struct sListEntry));
    if (le) {
        le->value = strdup(newVal);
        le->prev = ll->prev;
        le->next = NULL;
        if (le->prev)
            le->prev->next = le;
        else
            ll->next = le;
        ll->prev = le;
    }
    return (le!= NULL);
}

int LI_Insert(LIterator iter, const char *newVal)
{
    ListEntry crnt = iter->link;
    ListEntry le = malloc(sizeof(struct sListEntry));
    if (le) {
        le->value = strdup(newVal);
        if ( crnt == iter->head) {
            le->prev = NULL;
            le->next = crnt->next;
            crnt->next = le;
            if (le->next)
                le->next->prev = le;
            else
                crnt->prev = le;
        }
        else {
            le->prev = ( crnt == NULL)? iter->head->prev : crnt->prev;
            le->next = crnt;
            if (le->prev)
                le->prev->next = le;
            else
                iter->head->next = le;
            if (crnt)
                crnt->prev = le;
            else
                iter->head->prev = le;
        }
    }
    return (le!= NULL);
}

LIterator LL_GetIterator(LinkedList ll )
{
    LIterator liter = malloc(sizeof(struct sListIterator));
    liter->head = ll;
    liter->link = ll;
    return liter;
}

#define LLI_Delete( iter ) \
    {free(iter); \
    iter = NULL;}

int LLI_AtEnd(LIterator iter)
{
    return iter->link == NULL;
}
const char *LLI_Value(LIterator iter)
{
    return (iter->link)? iter->link->value: NULL;
}
int LLI_Next(LIterator iter)
{
    if (iter->link) iter->link = iter->link->next;
    return(iter->link != NULL);
}
int LLI_Prev(LIterator iter)
{
    if (iter->link) iter->link = iter->link->prev;
    return(iter->link != NULL);
}

int main()
{
    static const char *contents[] = {"Read", "Orage", "Yeller",
                                     "Glean", "Blew", "Burple"};
    int ix;
    LinkedList ll = NewList();    //new linked list
    LIterator iter;

    for (ix=0; ix<6; ix++)        //insert contents
        LL_Append(ll, contents[ix]);

    iter = LL_GetIterator(ll);    //get an iterator
    printf("forward\n");
    while(LLI_Next(iter))         //iterate forward
        printf("value=%s\n", LLI_Value(iter));
    LLI_Delete(iter);             //delete iterator

    printf("\nreverse\n");
    iter = LL_GetIterator(ll);
    while(LLI_Prev(iter))         //iterate reverse
        printf("value=%s\n", LLI_Value(iter));
    LLI_Delete(iter);
                        //uhhh-- delete list??
    return 0;
}


using System;
using System.Collections.Generic;

namespace RosettaCode.DoublyLinkedList
{
    internal static class Program
    {
        private static void Main()
        {
            var list = new LinkedList<char>("hello");

            var current = list.First;
            do
            {
                Console.WriteLine(current.Value);
            } while ((current = current.Next) != null);

            Console.WriteLine();

            current = list.Last;
            do
            {
                Console.WriteLine(current.Value);
            } while ((current = current.Previous) != null);
        }
    }
}


#include <iostream>
#include <list>

int main ()
{
    std::list<int> numbers {1, 5, 7, 0, 3, 2};
    for(const auto& i: numbers)
        std::cout << i << ' ';
    std::cout << '\n';
}


(def dl (double-list [:a :b :c :d]))
;=> #'user/dl

((juxt seq rseq) dl)
;=> [(:a :b :c :d) (:d :c :b :a)]

(take-while identity (iterate get-next (get-head dl)))
;=> (#:double_list.Node{:prev nil,          :next #<Object...>, :data :a, :key #<Object...>}
;=>  #:double_list.Node{:prev #<Object...>, :next #<Object...>, :data :b, :key #<Object...>}
;=>  #:double_list.Node{:prev #<Object...>, :next #<Object...>, :data :c, :key #<Object...>}
;=>  #:double_list.Node{:prev #<Object...>, :next nil,          :data :d, :key #<Object...>})

(take-while identity (iterate get-prev (get-tail dl)))

;=> (#:double_list.Node{:prev #<Object...>, :next nil,          :data :d, :key #<Object...>}
;=>  #:double_list.Node{:prev #<Object...>, :next #<Object...>, :data :c, :key #<Object...>}
;=>  #:double_list.Node{:prev #<Object...>, :next #<Object...>, :data :b, :key #<Object...>}
;=>  #:double_list.Node{:prev nil,          :next #<Object...>, :data :a, :key #<Object...>})


void main() {
    import std.stdio, std.container, std.range;

    auto dll = DList!dchar("DCBA"d.dup);

    dll[].writeln;
    dll[].retro.writeln;
}


uses system ;

type

   // declare the list pointer type
   plist = ^List ;

   // declare the list type, a generic data pointer prev and next pointers
   List = record
      data : pointer ;
      prev : pList ;
      next : pList ;
   end;

// since this task is just showing the traversal I am not allocating the memory and setting up the root node etc.
// Note the use of the carat symbol for de-referencing the pointer.

begin

   // beginning to end
   while not (pList^.Next = NIL) do pList := pList^.Next ;

   // end to beginning
   while not (pList^.prev = NIL) do pList := pList^.prev ;

end;


def traverse(list) {
    var node := list.atFirst()
    while (true) {
        println(node[])
        if (node.hasNext()) {
            node := node.next()
        } else {
            break
        }
    }
    while (true) {
        println(node[])
        if (node.hasPrev()) {
            node := node.prev()
        } else {
            break
        }
    }
}


open System.Collections.Generic

let first (l: LinkedList<char>) = l.First
let last (l: LinkedList<char>) = l.Last

let next (l: LinkedListNode<char>) = l.Next
let prev (l: LinkedListNode<char>) = l.Previous

let traverse g f (ls: LinkedList<char>) =
    let rec traverse (l: LinkedListNode<char>) =
        match l with
        | null -> ()
        | _ ->
            printf "%A" l.Value
            traverse (f l)
    traverse (g ls)

let traverseForward = traverse first next
let traverseBackward = traverse last prev

let cs = LinkedList(['a'..'z'])

traverseForward cs
printfn ""
traverseBackward cs


Dim As Integer i, MiLista()

For i = 0 To Int(Rnd * 100)+25
    Redim Preserve MiLista(i)
    MiLista(i) = Rnd * 314
Next

'Tour from the beginning
For i = Lbound(MiLista) To Ubound(MiLista)
    Print MiLista(i)
Next i

Print
'Travel from the end
For i = Ubound(MiLista) To Lbound(MiLista) Step -1
    Print MiLista(i)
Next i
Sleep


package main

import "fmt"

type dlNode struct {
    string
    next, prev *dlNode
}

type dlList struct {
    head, tail *dlNode
}

func (list *dlList) String() string {
    if list.head == nil {
        return fmt.Sprint(list.head)
    }
    r := "[" + list.head.string
    for p := list.head.next; p != nil; p = p.next {
        r += " " + p.string
    }
    return r + "]"
}

func (list *dlList) insertTail(node *dlNode) {
    if list.tail == nil {
        list.head = node
    } else {
        list.tail.next = node
    }
    node.next = nil
    node.prev = list.tail
    list.tail = node
}

func (list *dlList) insertAfter(existing, insert *dlNode) {
    insert.prev = existing
    insert.next = existing.next
    existing.next.prev = insert
    existing.next = insert
    if existing == list.tail {
        list.tail = insert
    }
}

func main() {
    dll := &dlList{}
    fmt.Println(dll)
    a := &dlNode{string: "A"}
    dll.insertTail(a)
    dll.insertTail(&dlNode{string: "B"})
    fmt.Println(dll)
    dll.insertAfter(a, &dlNode{string: "C"})
    fmt.Println(dll)

    // traverse from end to beginning
    fmt.Print("From tail:")
    for p := dll.tail; p != nil; p = p.prev {
        fmt.Print(" ", p.string)
    }
    fmt.Println("")
}


class DoubleLinkedListTraversing {
    static void main(args) {
        def linkedList = (1..9).collect() as LinkedList

        linkedList.each {
            print it
        }

        println()

        linkedList.reverseEach {
            print it
        }
    }
}


main = print . traverse True $ create [10,20,30,40]

data DList a = Leaf | Node { prev::(DList a), elt::a, next::(DList a) }

create = go Leaf
    where go _    []     = Leaf
          go prev (x:xs) = current
              where current = Node prev x next
                    next    = go current xs

isLeaf Leaf    = True
isLeaf _       = False

lastNode Leaf  = Leaf
lastNode dl    = until (isLeaf.next) next dl

traverse _    Leaf            = []
traverse True (Node l v Leaf) = v : v : traverse False l
traverse dir  (Node l v r)    = v : traverse dir (if dir then r else l)


class DoubleLink (value, prev_link, next_link)

  # insert given node after this one, removing its existing connections
  method insert_after (node)
    node.prev_link := self
    if (\next_link) then next_link.prev_link := node
    node.next_link := next_link
    self.next_link := node
  end

  # use a generator to traverse
  # - keep suspending the prev/next link until a null node is reached
  method traverse_backwards ()
    current := self
    while \current do {
      suspend current
      current := current.prev_link
    }
  end

  method traverse_forwards ()
    current := self
    while \current do {
      suspend current
      current := current.next_link
    }
  end

  initially (value, prev_link, next_link)
    self.value := value
    self.prev_link := prev_link    # links are 'null' if not given
    self.next_link := next_link
end

procedure main ()
  l1 := DoubleLink (1)
  l2 := DoubleLink (2)
  l1.insert_after (l2)
  l1.insert_after (DoubleLink (3))

  write ("Traverse from beginning to end")
  every (node := l1.traverse_forwards ()) do
    write (node.value)

  write ("Traverse from end to beginning")
  every (node := l2.traverse_backwards ()) do
    write (node.value)
end


traverse=:1 :0
  work=. result=. conew 'DoublyLinkedListHead'
  current=. y
  while. y ~: current=. successor__current do.
    work=. (work;result;<u data__current) conew 'DoublyLinkedListElement'
  end.
  result
)


package com.rosettacode;

import java.util.LinkedList;
import java.util.stream.Collectors;
import java.util.stream.IntStream;

public class DoubleLinkedListTraversing {

  public static void main(String[] args) {

    final LinkedList<String> doubleLinkedList =
        IntStream.range(1, 10)
            .mapToObj(String::valueOf)
            .collect(Collectors.toCollection(LinkedList::new));

    doubleLinkedList.iterator().forEachRemaining(System.out::print);
    System.out.println();
    doubleLinkedList.descendingIterator().forEachRemaining(System.out::print);
  }
}


DoublyLinkedList.prototype.getTail = function() {
    var tail;
    this.traverse(function(node){tail = node;});
    return tail;
}
DoublyLinkedList.prototype.traverseBackward = function(func) {
    func(this);
    if (this.prev() != null)
        this.prev().traverseBackward(func);
}
DoublyLinkedList.prototype.printBackward = function() {
    this.traverseBackward( function(node) {print(node.value())} );
}

var head = createDoublyLinkedListFromArray([10,20,30,40]);
head.print();
head.getTail().printBackward();


mutable struct DLNode{T}
    value::T
    pred::Union{DLNode{T}, Nothing}
    succ::Union{DLNode{T}, Nothing}
    DLNode(v) = new{typeof(v)}(v, nothing, nothing)
end

function insertpost(prevnode, node)
    succ = prevnode.succ
    prevnode.succ = node
    node.pred = prevnode
    node.succ = succ
    if succ != nothing
        succ.pred =  node
    end
    node
end

first(nd) = (while nd.pred != nothing nd = nd.prev end; nd)
last(nd) = (while nd.succ != nothing nd = nd.succ end; nd)

function printconnected(nd; fromtail = false)
    if fromtail
        nd = last(nd)
        print(nd.value)
        while nd.pred != nothing
            nd = nd.pred
            print(" -> $(nd.value)")
        end
    else
        nd = first(nd)
        print(nd.value)
        while nd.succ != nothing
            nd = nd.succ
            print(" -> $(nd.value)")
        end
    end
    println()
end

node1 = DLNode(1)
node2 = DLNode(2)
node3 = DLNode(3)
insertpost(node1, node2)
insertpost(node2, node3)
print("From beginning to end: "); printconnected(node1)
print("From end to beginning: "); printconnected(node1, fromtail = true)


// version 1.1.2

class LinkedList<E> {
    class Node<E>(var data: E, var prev: Node<E>? = null, var next: Node<E>? = null) {
        override fun toString(): String {
            val sb = StringBuilder(this.data.toString())
            var node = this.next
            while (node != null) {
                sb.append(" -> ", node.data.toString())
                node = node.next
            }
            return sb.toString()
        }
    }

    var first: Node<E>? = null
    var last:  Node<E>? = null

    fun addFirst(value: E) {
        if (first == null) {
            first = Node(value)
            last =  first
        }
        else {
            val node = first!!
            first = Node(value, null, node)
            node.prev = first
        }
    }

    fun addLast(value: E) {
        if (last == null) {
            last = Node(value)
            first = last
        }
        else {
            val node = last!!
            last = Node(value, node, null)
            node.next = last
        }
    }

    fun insert(after: Node<E>?, value: E) {
        if (after == null)
            addFirst(value)
        else if (after == last)
            addLast(value)
        else {
            val next = after.next
            val new = Node(value, after, next)
            after.next = new
            if (next != null) next.prev = new
        }
    }

    override fun toString() = first.toString()

    fun firstToLast() = first?.toString() ?: ""

    fun lastToFirst(): String {
        if (last == null) return ""
        val sb = StringBuilder(last.toString())
        var node = last!!.prev
        while (node != null) {
             sb.append(" -> ", node.data.toString())
             node = node.prev
        }
        return sb.toString()
    }
}

fun main(args: Array<String>) {
    val ll = LinkedList<Int>()
    ll.addFirst(1)
    ll.addLast(4)
    ll.insert(ll.first, 2)
    ll.insert(ll.last!!.prev, 3)
    println("First to last : ${ll.firstToLast()}")
    println("Last to first : ${ll.lastToFirst()}")
}


--------------
-- TRAVERSAL:
--------------
List.iterateForward = function(self)
  local function iter(self, node)
    if node then return node.next else return self.head end
  end
  return iter, self, nil
end
List.iterateReverse = function(self)
  local function iter(self, node)
    if node then return node.prev else return self.tail end
  end
  return iter, self, nil
end

---------
-- TEST:
---------
local list = List()
for i = 1, 5 do list:insertTail(i) end
io.write("Forward: ") for node in list:iterateForward() do io.write(node.data..",") end print()
io.write("Reverse: ") for node in list:iterateReverse() do io.write(node.data..",") end print()


struct block,nxt as ulong,prev as ulong,nm as char[20],age as long'Our structure of the blocks in our list.

global hHeap
global hFirst
global hLast
global blockCount
global blockSize
blockSize=len(block.struct)

    call Init
    if hHeap=0 then
        print "Error occured! Could not create heap, exiting..."
        end
    end if

    FirstUser=New("David",20)
    notImportant=New("Jessica",35)
    notImportant=New("Joey",38)
    MiddleUser=New("Jack",56)
    notImportant=New("Amy",17)
    notImportant=New("Bob",28)
    LastUser=New("Kenny",56)

    print "-Traversing the list forwards"

    hCurrent=hFirst
    while hCurrent<>0
        print tab(2);dechex$(hCurrent);"   ";Block.name$(hCurrent);"   ";Block.age(hCurrent)
        hCurrent=Block.next(hCurrent)
    wend

    print
    print "-Deleting first, middle, and last person."

    call Delete FirstUser'1
    call Delete MiddleUser'2
    call Delete LastUser'3

    print
    print "-Traversing the list backwards"
    hCurrent=hLast
    while hCurrent<>0
        print tab(2);dechex$(hCurrent);"   ";Block.name$(hCurrent);"   ";Block.age(hCurrent)
        hCurrent=Block.prev(hCurrent)
    wend

call Uninit

end

function Block.next(hBlock)
    calldll #kernel32,"RtlMoveMemory",block as struct,hBlock as ulong,blockSize as long,ret as void
    Block.next=block.nxt.struct
end function

function Block.prev(hBlock)
    calldll #kernel32,"RtlMoveMemory",block as struct,hBlock as ulong,blockSize as long,ret as void
    Block.prev=block.prev.struct
end function

function Block.age(hBlock)
    calldll #kernel32,"RtlMoveMemory",block as struct,hBlock as ulong,blockSize as long,ret as void
    Block.age=block.age.struct
end function

function Block.name$(hBlock)
    calldll #kernel32,"RtlMoveMemory",block as struct,hBlock as ulong,blockSize as long,ret as void
    Block.name$=block.nm.struct
end function

sub Block.age hBlock,age
    calldll #kernel32,"RtlMoveMemory",block as struct,hBlock as ulong,blockSize as long,ret as void
    block.age.struct=age
    calldll #kernel32,"RtlMoveMemory",hBlock as ulong,block as struct,blockSize as long,ret as void
end sub

sub Block.name hBlock,name$
    calldll #kernel32,"RtlMoveMemory",block as struct,hBlock as ulong,blockSize as long,ret as void
    block.nm.struct=name$
    calldll #kernel32,"RtlMoveMemory",hBlock as ulong,block as struct,blockSize as long,ret as void
end sub

sub Block.next hBlock,nxt
    calldll #kernel32,"RtlMoveMemory",block as struct,hBlock as ulong,blockSize as long,ret as void
    block.nxt.struct=nxt
    calldll #kernel32,"RtlMoveMemory",hBlock as ulong,block as struct,blockSize as long,ret as void
end sub

sub Block.prev hBlock,prev
    calldll #kernel32,"RtlMoveMemory",block as struct,hBlock as ulong,blockSize as long,ret as void
    block.prev.struct=prev
    calldll #kernel32,"RtlMoveMemory",hBlock as ulong,block as struct,blockSize as long,ret as void
end sub

function New(name$,age)
    calldll #kernel32,"HeapAlloc",hHeap as ulong,_HEAP_ZERO_MEMORY as ulong,blockSize as long,New as ulong
    if New<>0 then
        blockCount=blockCount+1
        if hFirst=0 then
            hFirst=New
            hLast=New
        else
            call Block.next hLast,New
            call Block.prev New,hLast
            hLast=New
        end if
        call Block.name New,name$
        call Block.age New,age
    end if
end function

sub Delete hBlock
    if hBlock<>0 then
        blockCount=blockCount-1
        if blockCount=0 then
            hFirst=0
            hLast=0
        else
            if hBlock=hFirst then
                hFirst=Block.next(hBlock)
                call Block.prev hFirst,0
            else
                if hBlock=hLast then
                    hLast=Block.prev(hBlock)
                    call Block.next hLast,0
                else
                    call Block.next Block.prev(hBlock),Block.next(hBlock)
                    call Block.prev Block.next(hBlock),Block.prev(hBlock)
                end if
            end if
        end if
        calldll #kernel32,"HeapFree",hHeap as ulong,0 as long,hBlock as ulong,ret as void
    end if
end sub

sub Init
    calldll #kernel32,"HeapCreate",0 as long,10000 as long,0 as long,hHeap as ulong
end sub

sub Uninit
    calldll #kernel32,"HeapDestroy",hHeap as ulong,ret as void
end sub


type
  List[T] = object
    head, tail: Node[T]

  Node[T] = ref TNode[T]

  TNode[T] = object
    next, prev: Node[T]
    data: T

proc initList[T](): List[T] = discard

proc newNode[T](data: T): Node[T] =
  new(result)
  result.data = data

proc prepend[T](l: var List[T], n: Node[T]) =
  n.next = l.head
  if l.head != nil: l.head.prev = n
  l.head = n
  if l.tail == nil: l.tail = n

proc append[T](l: var List[T], n: Node[T]) =
  n.next = nil
  n.prev = l.tail
  if l.tail != nil:
    l.tail.next = n
  l.tail = n
  if l.head == nil:
    l.head = n

proc insertAfter[T](l: var List[T], r, n: Node[T]) =
  n.prev = r
  n.next = r.next
  n.next.prev = n
  r.next = n
  if r == l.tail: l.tail = n

proc remove[T](l: var List[T], n: Node[T]) =
  if n == l.tail: l.tail = n.prev
  if n == l.head: l.head = n.next
  if n.next != nil: n.next.prev = n.prev
  if n.prev != nil: n.prev.next = n.next

proc `$`[T](l: var List[T]): string =
  result = ""
  var n = l.head
  while n != nil:
    if result.len > 0: result.add(" -> ")
    result.add($n.data)
    n = n.next

iterator traverseForward[T](l: List[T]): T =
  var n = l.head
  while n != nil:
    yield n.data
    n = n.next

iterator traverseBackward[T](l: List[T]): T =
  var n = l.tail
  while n != nil:
    yield n.data
    n = n.prev

var l = initList[int]()
var n = newNode(12)
var m = newNode(13)
var i = newNode(14)
var j = newNode(15)
l.append(n)
l.prepend(m)
l.insertAfter(m, i)
l.prepend(j)
l.remove(m)

for i in l.traverseForward():
  echo "> ", i

for i in l.traverseBackward():
  echo "< ", i


MODULE Collections;
IMPORT Box;

TYPE
  Action = PROCEDURE (o: Box.Object);

        PROCEDURE (dll: DLList) GoForth*(do: Action);
	VAR
		iter: Node;
	BEGIN
		iter := dll.first;
		WHILE iter # NIL DO
			do(iter.value);
			iter := iter.next
		END
	END GoForth;

	PROCEDURE (dll: DLList) GoBack*(do: Action);
	VAR
		iter: Node;
	BEGIN
		ASSERT(dll.last # NIL);
		iter := dll.last;
		WHILE iter # NIL DO
			do(iter.value);
			iter := iter.prev
		END
	END GoBack;

END Collections.


class Traverse {
   function : Main(args : String[]) ~ Nil {
      list := Collection.IntList->New();
      list->Insert(100);
      list->Insert(50);
      list->Insert(25);
      list->Insert(10);
      list->Insert(5);

      "-- forward --"->PrintLine();
      list->Rewind();
      while(list->More()) {
         list->Get()->PrintLine();
         list->Next();
      };

      "-- backward --"->PrintLine();
      list->Forward();
      while(list->More()) {
         list->Get()->PrintLine();
         list->Previous();
      };
   }
}


DList method: forEachNext
   dup ifNull: [ drop @head ifNull: [ false ] else: [ @head @head true] return ]
   next dup ifNull: [ drop false ] else: [ dup true ] ;

DList method: forEachPrev
   dup ifNull: [ drop @tail ifNull: [ false ] else: [ @tail @tail true] return ]
   prev dup ifNull: [ drop false ] else: [ dup true ] ;

: test
| dl n |
   DList new ->dl
   dl insertFront("A")
   dl insertBack("B")
   dl head insertAfter(DNode new("C", null , null))

   "Traversal (beginning to end) : " println
   dl forEach: n [ n . ]

   "\nTraversal (end to beginning) : " println
   dl revEach: n [ n . ] ;


declare
  proc {Walk Node Action}
     case Node of nil then skip
     [] node(value:V next:N ...) then
	{Action V}
	{Walk @N Action}
     end
  end

  proc {WalkBackwards Node Action}
     Tail = {GetLast Node}
     proc {Loop N}
	case N of nil then skip
	[] node(value:V prev:P ...) then
	   {Action V}
	   {Loop @P}
	end
     end
  in
     {Loop Tail}
  end

  fun {GetLast Node}
     case @(Node.next) of nil then Node
     [] NextNode=node(...) then {GetLast NextNode}
     end
  end

  fun {CreateNewNode Value}
     node(prev:{NewCell nil}
          next:{NewCell nil}
          value:Value)
  end

  proc {InsertAfter Node NewNode}
     Next = Node.next
  in
     (NewNode.next) := @Next
     (NewNode.prev) := Node
     case @Next of nil then skip
     [] node(prev:NextPrev ...) then
        NextPrev := NewNode
     end
     Next := NewNode
  end

  A = {CreateNewNode a}
  B = {CreateNewNode b}
  C = {CreateNewNode c}
in
  {InsertAfter A B}
  {InsertAfter A C}
  {Walk A Show}
  {WalkBackwards A Show}


enum NEXT,PREV,DATA
constant empty_dll = {{1,1}}
sequence dll = deep_copy(empty_dll)

procedure insert_after(object data, integer pos=1)
    integer prv = dll[pos][PREV]
    dll = append(dll,{pos,prv,data})
    if prv!=0 then
        dll[prv][NEXT] = length(dll)
    end if
    dll[pos][PREV] = length(dll)
end procedure

insert_after("ONE")
insert_after("TWO")
insert_after("THREE")

?dll

procedure show(integer d)
integer idx = dll[1][d]
    while idx!=1 do
        ?dll[idx][DATA]
        idx = dll[idx][d]
    end while
end procedure
show(NEXT)
?"=="
show(PREV)


# Print the elements a doubly-linked list
(de 2print (DLst)
   (for (L (car DLst) L (cddr L))
      (printsp (car L)) )
   (prinl) )

# Print the elements a doubly-linked list in reverse order
(de 2printReversed (DLst)
   (for (L (cdr DLst) L (cadr L))
      (printsp (car L)) )
   (prinl) )


/* To implement a doubly-linked list -- i.e., a 2-way linked list. */
doubly_linked_list: proc options (main);

   define structure
      1 node,
         2 value fixed,
         2 fwd_pointer handle(node),
         2 back_pointer handle(node);

   declare (head, tail, t) handle (node);
   declare null builtin;
   declare i fixed binary;

   head, tail = bind(:node, null:);

   do i = 1 to 10; /* Add ten items to the tail of the queue. */
      if head = bind(:node, null:) then
         do;
            head,tail = new(:node:);
            get list (head => value);
            put skip list (head => value);
            head => back_pointer,
            head => fwd_pointer = bind(:node, null:); /* A NULL link */
         end;
      else
         do;
            t = new(:node:);
            t => back_pointer = tail; /* Point the new tail back to the old */
                                      /* tail.                              */
            tail => fwd_pointer = t;  /* Point the tail to the new node.    */
            t => back_pointer = tail; /* Point the new tail back to the old */
                                      /*  tail.                             */
            tail = t;                 /* Point at the new tail.             */
            tail => fwd_pointer = bind(:node, null:);
                                      /* Set the tail link to NULL          */
            get list (tail => value) copy;
            put skip list (tail => value);
         end;
   end;

   if head = bind(:node, null:) then return; /* Empty list. */

   /* Traverse the list from the head. */
   put skip list ('In a forwards direction, the list has:');
   t = head;
   do while (t ^= bind(:node, null:));
      put skip list (t => value);
      t = t => fwd_pointer;
   end;
   /* Traverse the list from the tail to the head. */
   put skip list ('In the reverse direction, the list has:');
   t = tail;
   do while (t ^= bind(:node, null:));
      put skip list (t => value);
      t = t => back_pointer;
   end;
end doubly_linked_list;


NewList MyData.i() ; Create a double linked list holding a single value (integer)

;Set up a randomly long linked list in the range 25-125 elements
For i=0 To (Random(100)+25)
  AddElement(MyData())        ; Create a new tailing element
  MyData()=Random(314)        ; Inert a vale into it
Next
;
;Traverse from the beginning of a doubly-linked list to the end.
FirstElement(MyData())
Repeat
  Debug MyData()              ; Present the value in the current cell
Until Not NextElement(MyData())
;
;Traverse from the end to the beginning.
LastElement(MyData())
Repeat
   Debug MyData()             ; Present the value in the current cell
Until Not PreviousElement(MyData())


class List:
    def __init__(self, data, next=None, prev=None):
        self.data = data
        self.next = next
        self.prev = prev

    def append(self, data):
        if self.next == None:
            self.next = List(data, None, self)
            return self.next
        else:
            return self.next.append(data)

# Build the list
tail = head = List(10)
for i in [ 20, 30, 40 ]:
    tail = tail.append(i)

# Traverse forwards
node = head
while node != None:
    print(node.data)
    node = node.next

# Traverse Backwards
node = tail
while node != None:
    print(node.data)
    node = node.prev


(define (dlist-elements dlist)
  (let loop ([elements '()] [dlink (dlist-tail dlist)])
    (if dlink
        (loop (cons (dlink-content dlink) elements) (dlink-prev dlink))
        elements)))

(define (dlist-elements/reverse dlist)
  (let loop ([elements '()] [dlink (dlist-head dlist)])
    (if dlink
        (loop (cons (dlink-content dlink) elements) (dlink-next dlink))
        elements)))