2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Copyright (c) 2012 Anonymous
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! See http://factorcode.org/license.txt for BSD license.
							 | 
						
					
						
							
								
									
										
										
										
											2014-11-11 21:00:44 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								USING: arrays fry kernel math.matrices sequences ;
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: rosetta-code.bitmap
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! http://rosettacode.org/wiki/Basic_bitmap_storage
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Show a basic storage type to handle a simple RGB raster
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! graphics image, and some primitive associated functions.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! If possible provide a function to allocate an uninitialised
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! image, given its width and height, and provide 3 additional
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! functions:
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! * one to fill an image with a plain RGB color,
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! * one to set a given pixel with a color,
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! * one to get the color of a pixel.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! (If there are specificities about the storage or the
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! allocation, explain those.)
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Various utilities
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: meach ( matrix quot -- ) [ each ] curry each ; inline
							 | 
						
					
						
							
								
									
										
										
										
											2015-06-29 19:43:15 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: meach-index ( matrix quot -- )
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ swap 2array ] prepose
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ curry each-index ] curry each-index ; inline
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: mmap ( matrix quot -- matrix' ) [ map ] curry map ; inline
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: mmap! ( matrix quot -- matrix' ) [ map! ] curry map! ; inline
							 | 
						
					
						
							
								
									
										
										
										
											2015-06-29 19:43:15 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: mmap-index ( matrix quot -- matrix' )
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ swap 2array ] prepose
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ curry map-index ] curry map-index ; inline
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: matrix-dim ( matrix -- i j ) [ length ] [ first length ] bi ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: set-Mi,j ( elt {i,j} matrix -- ) [ first2 swap ] dip nth set-nth ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: Mi,j ( {i,j} matrix -- elt ) [ first2 swap ] dip nth nth ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! The storage functions
							 | 
						
					
						
							
								
									
										
										
										
											2015-06-29 19:43:15 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: <raster-image> ( width height -- image )
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    zero-matrix [ drop { 0 0 0 } ] mmap ;
							 | 
						
					
						
							
								
									
										
										
										
											2015-06-29 19:43:15 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: fill-image ( {R,G,B} image -- image )
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    swap '[ drop _ ] mmap! ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: set-pixel ( {R,G,B} {i,j} image -- ) set-Mi,j ; inline
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: get-pixel ( {i,j} image -- pixel ) Mi,j ; inline
							 |