CDE

Task/Bitmap-Write-a-PPM-file/Common-Lisp/bitmap-write-a-ppm-file.lisp

@@ -0,0 +1,28 @@
+(defun write-rgb-buffer-to-ppm-file (filename buffer)
+  (with-open-file (stream filename
+			  :element-type '(unsigned-byte 8)
+			  :direction :output
+			  :if-does-not-exist :create
+			  :if-exists :supersede)
+    (let* ((dimensions (array-dimensions buffer))
+	   (width (first dimensions))
+	   (height (second dimensions))
+	   (header (format nil "P6~A~D ~D~A255~A"
+			   #\newline
+			   width height #\newline
+			   #\newline)))
+      (loop
+	 :for char :across header
+	 :do (write-byte (char-code char) stream)) #| Assumes char-codes match ASCII |#
+
+      (loop
+	 :for x :upfrom 0 :below width
+	 :do (loop :for y :upfrom 0 :below height
+		:do (let ((pixel (rgb-pixel buffer x y)))
+		      (let ((red (rgb-pixel-red pixel))
+			    (green (rgb-pixel-green pixel))
+			    (blue (rgb-pixel-blue pixel)))
+			(write-byte red stream)
+			(write-byte green stream)
+			(write-byte blue stream)))))))
+  filename)

Task/Bitmap-Write-a-PPM-file/Euphoria/bitmap-write-a-ppm-file-1.euphoria

@@ -0,0 +1,15 @@
+constant dimx = 800, dimy = 800
+constant fn = open("first.ppm","wb") -- b - binary mode
+sequence color
+printf(fn, "P6\n%d %d\n255\n", {dimx,dimy})
+for j = 0 to dimy-1 do
+    for i = 0 to dimx-1 do
+        color = {
+            remainder(i,256), -- red
+            remainder(j,256), -- green
+            remainder(i*j,256) -- blue
+        }
+        puts(fn,color)
+    end for
+end for
+close(fn)

Task/Bitmap-Write-a-PPM-file/Euphoria/bitmap-write-a-ppm-file-2.euphoria

@@ -0,0 +1,14 @@
+procedure write_ppm(sequence filename, sequence image)
+    integer fn,dimx,dimy
+    dimy = length(image[1])
+    dimx = length(image)
+    fn = open(filename,"wb")
+    printf(fn, "P6\n%d %d\n255\n", {dimx,dimy})
+    for y = 1 to dimy do
+        for x = 1 to dimx do
+            puts(fn, and_bits(image[x][y], {#FF0000,#FF00,#FF}) /
+                                           {#010000,#0100,#01}) -- unpack color triple
+        end for
+    end for
+    close(fn)
+end procedure