full-bitpal

#lang racket
(require 2htdp/image)
(define (subbits mask num)
  (if (or (odd? mask) (zero? mask))
      (bitwise-and mask num)
      (subbits (arithmetic-shift mask -1)
               (arithmetic-shift num -1))))
(define-values (above* beside*)
  (let ([helper
         (λ (f mt . xs)
           (cond
             [(empty? xs) mt]
             [(empty? (rest xs)) (first xs)]
             [else (apply f xs)]))])
    (values (curry helper above empty-image)
            (curry helper beside empty-image))))
(define split-list-by-count
  (letrec ([split-list-by-count-helper
            (lambda (n l r)
              (cond
                [(empty? r) l]
                [(>= (length (first l)) n)
                 (split-list-by-count-helper n (cons `() l) r)]
                [else
                 (split-list-by-count-helper
                  n (cons (cons (first r) (first l)) (rest l)) (rest r))]))])
    (lambda (n r)
      (reverse (map reverse (split-list-by-count-helper n `(()) r))))))
(define (square-full-of . images)
  (apply above*
         (map (curry apply beside*)
              (split-list-by-count
               (expt 2 (ceiling (/ (inexact->exact
                                    (floor (/ (log (length images))
                                              (log 2)))) 4)))
               images))))
(define (palette
         (red #xff0000)
         (green #x00ff00)
         (blue #x0000ff))
  (let* ([white (bitwise-ior red green blue)]
         [sqsize (inexact->exact
                  (min (max (floor (/ 256 (sqrt (+ 1 white))))
                            1) 24))])
    (lambda colors
      (apply square-full-of
             (map (lambda (x)
                    (square sqsize 'solid
                            (color (floor (/ (* (subbits red x) #xff)
                                             (if (zero? red) 1
                                                 (subbits red white))))
                                   (floor (/ (* (subbits green x) #xff)
                                             (if (zero? green) 1
                                                 (subbits green white))))
                                   (floor (/ (* (subbits blue x) #xff)
                                             (if (zero? blue) 1
                                                 (subbits blue white)))))))
                  colors)))))
(define (nat->bitlist n (l `()))
  (if (zero? n) l
      (nat->bitlist (arithmetic-shift n -1)
                    (cons (odd? n) l))))
(define (bitlist->nat l (n 0))
  (if (empty? l) n
      (bitlist->nat (rest l)
                    (bitwise-ior (if (first l) 1 0)
                                 (arithmetic-shift n 1)))))
(define (color-component-bitcounts bits)
  (case bits
    [(0) `(0 0 0)]
    [(1) `(1 0 0)]
    [(2) `(1 1 0)]
    [else
     (let ([field-width (/ bits 3)])
       (case (modulo bits 3)
         [(0) (list field-width field-width field-width)]
         [(1) (list (floor field-width)
                    (ceiling field-width)
                    (floor field-width))]
         [else (list (ceiling field-width)
                     (ceiling field-width)
                     (floor field-width))]))]))
(define (color-component-bitmasks bits)
  (let* ([affs
          (map (curryr build-list (lambda (_) #t))
               (color-component-bitcounts bits))]
         [negs (map (curry map not) affs)])
    (map bitlist->nat
         (list
          (append (first affs) (second negs) (third negs))
          (append (first negs) (second affs) (third negs))
          (append (first negs) (second negs) (third affs))))))
(define (bitpal bits)
  (apply palette (color-component-bitmasks bits)))
(define (full-bitpal bits)
  (apply (bitpal bits) (build-list (arithmetic-shift 1 bits) identity)))