-- This file is part of Quipper. Copyright (C) 2011-2016. Please see the
-- file COPYRIGHT for a list of authors, copyright holders, licensing,
-- and other details. All rights reserved.
-- 
-- ======================================================================

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}

-- | Pretty-printing of low-level quantum circuits.

module Quipper.Printing (
  -- * ASCII representation of circuits
  ascii_of_bcircuit,
  print_dbcircuit_ascii,
  getBit,
  -- * Gate counts
  print_gatecounts_bcircuit,
  -- * Graphical representation of circuits
  render_dbcircuit,
  -- * Previewing
  preview_bcircuit,
  -- * Printing to multiple formats
  Format(..),
  FormatStyle(..),
  pdf,
  eps,
  ps,
  format_enum,
  print_dbcircuit,
  print_of_document,
  print_of_document_custom,
  -- * Generic printing
  print_unary,
  print_generic,
  print_simple,
  ) where

-- import other Quipper stuff
import Libraries.Auxiliary
import Quipper.Circuit
import Quipper.Generic
import Quipper.Monad
import Quipper.QData

-- import other stuff
import Prelude
import Text.Printf
import Data.Char(isSpace)
import Data.List
import Data.Maybe
import Control.Monad(when)
import Graphics.EasyRender
import System.IO
import System.Process
import System.Directory
import System.Environment
import System.Info

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Map (Map)
import qualified Data.Map as Map

import qualified Data.IntMap as IntMap
import qualified Data.List as List

-- ======================================================================
-- * Auxiliary functions

-- | Determine whether a named gate is self-inverse. The kind of a
-- gate is uniquely determined by its name, and the number of input
-- wires and generalized controls.
-- 
-- For now, we only recognize "X", "Y", "Z", "H", "not", "swap", and
-- "W" as self-inverse; it is not currently possible for user code to
-- extend this list.
self_inverse :: String -> [Wire] -> [Wire] -> Bool
self_inverse "X" [q] [] = True
self_inverse "Y" [q] [] = True
self_inverse "Z" [q] [] = True
self_inverse "H" [q] [] = True
self_inverse "not" [q] [] = True
self_inverse "swap" [q1,q2] [] = True
self_inverse "W" [q1,q2] [] = True
self_inverse _ _ _ = False

-- ======================================================================
-- * ASCII representation of circuits

-- $ Convert a circuit to ASCII: one gate per line.

type WireTypeMap = IntMap.IntMap Wiretype

-- | Given a map of wiretypes, and a gate, update the wiretype in the map
-- if the gate changes it.
track_wiretype :: WireTypeMap -> Gate -> WireTypeMap
track_wiretype wtm (QInit    _ w _  ) = IntMap.insert w Qbit wtm
track_wiretype wtm (CInit    _ w _  ) = IntMap.insert w Cbit wtm
track_wiretype wtm (QMeas      w    ) = IntMap.insert w Cbit wtm
track_wiretype wtm (CGate    _ w _ _) = IntMap.insert w Cbit wtm
track_wiretype wtm (CGateInv _ w _ _) = IntMap.insert w Cbit wtm
track_wiretype wtm (QPrep      w _  ) = IntMap.insert w Qbit wtm
track_wiretype wtm (QUnprep    w _  ) = IntMap.insert w Cbit wtm
track_wiretype wtm (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep) = a2 `IntMap.union` wtm 
track_wiretype wtm _ = wtm

-- | Convert a 'BoxId' to the string in the format \"/name/\", shape \"/x/\".
ascii_of_boxid :: BoxId -> String
ascii_of_boxid (BoxId name shape) = show name ++ ", shape " ++ show shape

-- | Generate an ASCII representation of a control. 
-- As controls are stored as untyped wires, we can lookup the wiretype in
-- the current map and annotate the control if it's classical.
ascii_render_control :: WireTypeMap -> Signed Wire -> String
ascii_render_control wtm (Signed w b) =
  (if b then "+" else "-") ++ show w ++ ascii_render_control_type wtype
  where 
    wtype = if (w `IntMap.member` wtm) then (wtm IntMap.! w) else Qbit
    ascii_render_control_type Qbit = ""
    ascii_render_control_type Cbit = "c"

-- | Generate an ASCII representation of a list of controls.
ascii_render_controls :: WireTypeMap -> Controls -> String
ascii_render_controls wtm c =
  string_of_list " with controls=[" ", " "]" "" (ascii_render_control wtm) c

-- | Generate an ASCII representation of a NoControlFlag
ascii_render_nocontrolflag :: NoControlFlag -> String
ascii_render_nocontrolflag False = ""
ascii_render_nocontrolflag True = " with nocontrol"

-- | Generate an ASCII representation of a single gate.
ascii_render_gate :: WireTypeMap -> Gate -> String
ascii_render_gate wtm (QGate "trace" _ _ _ _ _) = ""
ascii_render_gate wtm (QGate name inv ws1 ws2 c ncf) = 
  "QGate[" ++ show name ++ "]" 
  ++ optional inv' "*"
  ++ (string_of_list "(" "," ")" "()" show ws1)
  ++ (string_of_list "; [" "," "]" "" show ws2)
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
  where
    inv' = inv && not (self_inverse name ws1 ws2)
ascii_render_gate wtm (QRot name inv theta ws1 ws2 c ncf) = 
  "QRot[" ++ show name ++ "," ++ (show theta) ++ "]" 
  ++ optional inv "*"
  ++ (string_of_list "(" "," ")" "()" show ws1)
  ++ (string_of_list "; [" "," "]" "" show ws2)
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (GPhase t ws c ncf) = 
  "GPhase() with t=" ++ show t 
  ++ ascii_render_controls wtm c 
  ++ ascii_render_nocontrolflag ncf
  ++ string_of_list " with anchors=[" ", " "]" "" show ws
ascii_render_gate wtm (CNot w c ncf) = 
  "CNot(" ++ show w ++ ")" 
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (CGate n w c ncf) = 
  -- special case
  "CGate[" ++ show n ++ "]" ++ (string_of_list "(" "," ")" "()" show (w:c))
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (CGateInv n w c ncf) = 
  "CGate[" ++ show n ++ "]" ++ "*" ++ (string_of_list "(" "," ")" "()" show (w:c))
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (CSwap w1 w2 c ncf) = 
  "CSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" 
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (QPrep w ncf) = 
  "QPrep(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (QUnprep w ncf) = 
  "QUnprep(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (QInit b w ncf) = 
  "QInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (CInit b w ncf) = 
  "CInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (QTerm b w ncf) = 
  "QTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (CTerm b w ncf) = 
  "CTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
  ++ ascii_render_nocontrolflag ncf
ascii_render_gate wtm (QMeas w) = 
  "QMeas(" ++ show w ++ ")"
ascii_render_gate wtm (QDiscard w) = 
  "QDiscard(" ++ show w ++ ")"
ascii_render_gate wtm (CDiscard w) = 
  "CDiscard(" ++ show w ++ ")"
ascii_render_gate wtm (DTerm b w) = 
  "DTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"
ascii_render_gate wtm (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep) = 
  "Subroutine" ++ show_rep ++ "[" ++ ascii_of_boxid boxid ++ "]"
  ++ optional inv "*"
  ++ " "
  ++ (string_of_list "(" "," ")" "()" show ws1)
  ++ (string_of_list " -> (" "," ")" "()" show ws2)
  ++ ascii_render_controls wtm c
  ++ ascii_render_nocontrolflag ncf
  where
    show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")"
ascii_render_gate wtm (Comment s inv ws) = 
  "Comment[" ++ show s ++ "]" 
  ++ optional inv "*"
  ++ (string_of_list "(" ", " ")" "()" (\(w,s) -> show w ++ ":" ++ show s) ws)
  
-- | Generate an ASCII representation of a gate list.
ascii_render_gatelist :: WireTypeMap -> [Gate] -> String
ascii_render_gatelist wtm []     = ""
ascii_render_gatelist wtm (g:gs) =
  (ascii_render_gate wtm g) ++ "\n" ++ 
  (ascii_render_gatelist (track_wiretype wtm g) gs)
  where

-- | Generate an ASCII representation of a wiretype.
ascii_render_wiretype :: Wiretype -> String
ascii_render_wiretype Qbit = "Qbit"
ascii_render_wiretype Cbit = "Cbit"

-- | Generate an ASCII representation of a type assignment.
ascii_render_typeas :: (Wire, Wiretype) -> String
ascii_render_typeas (w, t) =
  show w ++ ":" ++ ascii_render_wiretype t

-- | Generate an ASCII representation of an arity, preceded by a title
-- (input or output).
ascii_render_arity :: String -> Arity -> String
ascii_render_arity title a =
  title ++ ": " ++ (string_of_list "" ", " "" "none" ascii_render_typeas (IntMap.toList a)) ++ "\n"

-- | Generate an ASCII representation of an ordered arity, preceded by
-- a title (input or output).
ascii_render_oarity :: String -> [Wire] -> Arity -> String
ascii_render_oarity title ws a =
  title ++ ": " 
  ++ (string_of_list "" ", " "" "none" ascii_render_typeas tas_list) ++ "\n"
  where
    tas_list = [ (w, a IntMap.! w) | w <- ws ]

-- | Generate an ASCII representation of a low-level ordered quantum
-- circuit.
ascii_of_ocircuit :: OCircuit -> String
ascii_of_ocircuit ocircuit = 
  (ascii_render_oarity "Inputs" win a1) ++
  (ascii_render_gatelist a1 gl) ++
  (ascii_render_oarity "Outputs" wout a2)
    where
      OCircuit (win, circuit, wout) = ocircuit
      (a1, gl, a2, _) = circuit

-- | Generate an ASCII representation of a low-level quantum circuit.
ascii_of_circuit :: Circuit -> String
ascii_of_circuit circuit = ascii_of_ocircuit ocircuit where
  ocircuit = OCircuit (w_in, circuit, w_out)
  (a1, _, a2, _) = circuit
  w_in = IntMap.keys a1
  w_out = IntMap.keys a2

-- | Generate an ASCII representation of a low-level boxed quantum
-- circuit.
ascii_of_bcircuit :: BCircuit -> String
ascii_of_bcircuit (c,s) = 
  (ascii_of_circuit c) ++
  (concat $ map ascii_of_subroutine (Map.toList s)) ++
  "\n"

-- | Generate an ASCII representation of a named subroutine.
ascii_of_subroutine :: (BoxId, TypedSubroutine) -> String
ascii_of_subroutine (boxid, TypedSubroutine ocirc input_strux output_strux ctrble) =
  "\n" 
  ++ "Subroutine: " ++ show name ++ "\n"
  ++ "Shape: " ++ show shape ++ "\n"
  ++ "Controllable: " ++ (case ctrble of {AllCtl -> "yes"; NoCtl -> "no"; OnlyClassicalCtl -> "classically"}) ++ "\n"
  ++ ascii_of_ocircuit ocirc
    where
      BoxId name shape = boxid
  
-- ======================================================================
-- * Dynamic ASCII representation of circuits

-- $
-- The dynamic ASCII representation prints a circuit to standard
-- output in ASCII format, just like the static ASCII representation.
-- However, when a 'dynamic_lift' operation is encountered, it prompts
-- the user for the value of the corresponding bit. In effect, the
-- user is asked to act as the quantum device or simulator.   

-- | Write a prompt to get input from the user. Since the prompt
-- doesn't include a newline, the output must be flushed explicitly.
prompt :: String -> IO ()
prompt s = do
  putStr s
  hFlush stdout

-- | Interactively read a bit (either 0 or 1) from standard input.
-- This is intended for interactive user input, so it skips white
-- space until a 0 or 1 is encountered. In case the first
-- non-whitespace character isn't 0 or 1 or '#', the rest of the line
-- is ignored and the user is prompted to try again.
-- 
-- However, this also works for non-interactive input, so that the
-- input can be redirected from a file. In this case, the characters 0
-- and 1 and whitespace, including newlines, can be interspersed
-- freely. \'@#@\' starts a comment that extends until the end of the
-- line. 
getBit :: IO Bool
getBit = do
  c <- getChar
  case c of
    '0' -> return False
    '1' -> return True
    '#' -> do
      getLine
      getBit
    c | isSpace c -> getBit
    c -> do
      getLine
      prompt $ "# Expecting 0 or 1. Please try again: "
      getBit

-- | Embed a read-write computation in the 'IO' monad, by writing
-- gates to the terminal and interactively querying the user (or a
-- file on stdin) for dynamic liftings. We also update a 'Namespace'
-- while doing so, to collect any subroutines that are defined along
-- the way.
run_readwrite_ascii :: WireTypeMap -> ReadWrite a -> Namespace -> IO (a, Namespace)
run_readwrite_ascii wtm (RW_Return a) ns = return (a, ns)
run_readwrite_ascii wtm (RW_Write gate comp) ns = do
  putStrLn (ascii_render_gate wtm gate)
  run_readwrite_ascii (track_wiretype wtm gate) comp ns
run_readwrite_ascii wtm (RW_Read w cont) ns = do
  prompt $ "# Value of wire " ++ show w ++ ": "
  bool <- getBit
  putStrLn $ "# Value: " ++ show bool
  run_readwrite_ascii wtm (cont bool) ns
run_readwrite_ascii wtm (RW_Subroutine name subroutine comp) ns = do
  let !ns' = map_provide name subroutine ns
  run_readwrite_ascii wtm comp ns'

-- | Interactively output a 'DBCircuit' to standard output. This
-- supports dynamic lifting by prompting the user for bit values when
-- a dynamic lifting operation is encountered. Effectively the user is
-- asked to behave like a quantum device.
print_dbcircuit_ascii :: ErrMsg -> DBCircuit a -> IO ()
print_dbcircuit_ascii _ (a0, comp) = do
  hSetBuffering stdout LineBuffering -- flush output after each line
  putStr (ascii_render_arity "Inputs" a0)
  ((a1, _, _),ns) <- run_readwrite_ascii a0 comp namespace_empty
  putStr (ascii_render_arity "Outputs" a1)
  sequence_ [ putStr $ ascii_of_subroutine subr | subr <- Map.toList ns ]
  putStr "\n"

-- ----------------------------------------------------------------------
-- * Graphical representation of circuits

-- | The color white.
white :: Color
white = Color_Gray 1.0

-- | The color black.
black :: Color
black = Color_Gray 0.0

-- | A data type that holds all the customizable parameters.
data FormatStyle = FormatStyle {
  -- | The RenderFormat to use.
  renderformat :: RenderFormat,
  -- | The color of the background.
  backgroundcolor :: Color,
  -- | The color of the foreground (e.g. wires and gates).
  foregroundcolor :: Color,
  -- | Line width.
  linewidth :: Double,
  -- | Gap for double line representing classical bit.
  coffs :: Double,
  -- | Radius of dots for \"controlled\" gates.
  dotradius :: Double,
  -- | Radius of oplus for \"not\" gate.
  oplusradius :: Double,
  -- | Horizontal column width.
  xoff :: Double,
  -- | Difference between width of box and width of label.
  gatepad :: Double,
  -- | Height of labelled box.
  gateheight :: Double,
  -- | Width and height of \"cross\" for swap gate.
  crossradius :: Double,
  -- | Vertical shift for text labels.
  stringbase :: Double,
  -- | Width of \"bar\" bar.
  barwidth :: Double, 
  -- | Height of \"bar\" bar.
  barheight :: Double,
  -- | Width of \"D\" symbol.
  dwidth :: Double,
  -- | Height of \"D\" symbol.
  dheight :: Double,
  -- | Maximal width of a gate label.
  maxgatelabelwidth :: Double,
  -- | Maximal width of a wire label.
  maxlabelwidth :: Double,
  -- | Maximal width of a wire number.
  maxnumberwidth :: Double,
  -- | Font to use for labels on gates.
  gatefont :: Font,
  -- | Font to use for comments.
  commentfont :: Font,
  -- | Color to use for comments.
  commentcolor :: Color,
  -- | Font to use for labels.
  labelfont :: Font,
  -- | Color to use for labels.
  labelcolor :: Color,
  -- | Font to use for numbers.
  numberfont :: Font,
  -- | Color to use for numbers.
  numbercolor :: Color,
  -- | Whether to label each subroutine call with shape parameters
  subroutineshape :: Bool
} deriving Show

-- | A RenderFormat consisting of some default parameters, 
-- along with the given RenderFormat.
defaultStyle :: RenderFormat -> FormatStyle
defaultStyle rf = FormatStyle {
  renderformat = rf,
  backgroundcolor = white,
  foregroundcolor = black,
  linewidth = 0.02, 
  coffs = 0.03,
  dotradius  = 0.15,
  oplusradius = 0.25,
  xoff = 1.5,
  gatepad = 0.3, 
  gateheight  = 0.8,
  crossradius = 0.2,
  stringbase = 0.25,
  barwidth = 0.1,
  barheight = 0.5,
  dwidth = 0.3,
  dheight = 0.4,
  maxgatelabelwidth = 1.1,
  maxlabelwidth = 0.7,
  maxnumberwidth = 0.7,
  gatefont = Font TimesRoman 0.5,
  commentfont = Font TimesRoman 0.3,
  commentcolor = Color_RGB 1 0.2 0.2,
  labelfont = Font TimesRoman 0.3,
  labelcolor = Color_RGB 0 0 1,
  numberfont = Font Helvetica 0.5,
  numbercolor = Color_RGB 0 0.7 0,
  subroutineshape = True
}

-- | The default PDF Style.
pdf :: FormatStyle
pdf = defaultStyle Format_PDF

-- | The default EPS Style.
eps :: FormatStyle
eps = defaultStyle (Format_EPS 1)

-- | The default PS Style.
ps :: FormatStyle
ps = defaultStyle (Format_PS)

-- ----------------------------------------------------------------------
-- ** General-purpose PostScript functions

-- | Escape special characters in a string literal.
ps_escape :: String -> String
ps_escape [] = []
ps_escape ('\\' : t) = '\\' : '\\' : ps_escape t
ps_escape ('('  : t) = '\\' : '('  : ps_escape t
ps_escape (')'  : t) = '\\' : ')'  : ps_escape t
ps_escape (h : t)    = h : ps_escape t

-- ----------------------------------------------------------------------
-- ** String formatting

-- | Convert a 'BoxId' to the string in the format \"/name/, shape /x/\".
string_of_boxid :: BoxId -> String
string_of_boxid (BoxId name shape) = name ++ ", shape " ++ shape

-- ----------------------------------------------------------------------
-- ** Functions for dealing with x-coordinates

-- | Pre-processing: figure out the /x/-column of each gate. Returns
-- (/n/,/xgs/) where /xgs/ is a list of ('Gate', 'X') pairs, and
-- /n/ is the rightmost /x/-coordinate of the circuit. Here we start
-- from /x0/ and use constant step /xoff/ taken from the 'FormatStyle'.
assign_x_coordinates :: FormatStyle -> [Gate] -> X -> (X, [(Gate, X)])
assign_x_coordinates fs gs x0 =
  let ((x,ws), xgs) = mapAccumL (\ (x, ws) g ->
        -- count the wires attached to the gate. If there is precisely
        -- one (unary gate), merge it with adjacent unary gates. Do
        -- not merge comments.
        let merge = case (g, wirelist_of_gate g) of
              (Comment _ _ _, _) -> Nothing
              (_, [w]) -> Just w
              (_, _) -> Nothing
        in
        case merge of
          Just w ->
            if not (w `elem` ws) then
              ((x, w:ws), (g, x))
            else
              ((x + (xoff fs), [w]), (g, x + (xoff fs)))
          _ ->
            if ws == [] then
              ((x + (xoff fs), []), (g, x))
            else
              ((x + 2.0 * (xoff fs), []), (g, x + (xoff fs)))
        ) (x0, []) gs
  in
   if ws == [] then
     (x, xgs)
   else
     (x + (xoff fs), xgs)

-- | A 'Xarity' is a map from wire id's to pairs of a wiretype and a
-- starting /x/-coordinate.
type Xarity = Map Wire (Wiretype, X)

-- | Figure out how a gate at coordinate /x/ affects the current 'Xarity'.
-- Return a pair (/term/, /new/), where /term/ is the 'Xarity' of wires
-- terminated by this gate, and /new/ is the outgoing 'Xarity' of this
-- gate.
update_xarity :: Xarity -> Gate -> X -> (Xarity, Xarity)
update_xarity xarity gate x =
  let (win, wout) = gate_arity gate
      safe_lookup xarity w = 
        case Map.lookup w xarity of 
          Just x -> x
          Nothing -> (Qbit, x) -- error ("update_xarity: the wire " ++ show w ++ " does not exist. In the gate:\n" ++ ascii_render_gate gate)
      (win', wout') = (win \\ wout, wout \\ win)
      -- extract terminating wires from xarity
      xarity_term = foldl (\xar (w,_) -> Map.insert w (xarity `safe_lookup` w) xar) Map.empty win' 
      -- extract continuing wires from xarity
      xarity_cont = foldl (\xar (w,_) -> Map.delete w xar) xarity win'
      -- add new wires to xarity_cont
      xarity_new = foldl (\xar (w,t) -> Map.insert w (t,x) xar) xarity_cont wout'
  in
   (xarity_term, xarity_new)

-- ----------------------------------------------------------------------
-- ** Low-level drawing functions

-- | @'render_line' x0 y0 x1 y1@: Draw a line from (/x0/, /y0/)
-- to (/x1/, /y1/). In case of a zero-length line, draw nothing.
render_line :: X -> Y -> X -> Y -> Draw ()
render_line x0 y0 x1 y1 | x0 == x1 && y0 == y1 = return ()
render_line x0 y0 x1 y1 = draw_subroutine alt $ do
  moveto x0 y0
  lineto x1 y1
  stroke
  where
    alt = [custom_ps $ printf "%f %f %f %f line\n" x0 y0 x1 y1]

-- | @'render_dot' x y@: Draw a filled control dot at (/x/,/y/).
render_dot :: FormatStyle -> X -> Y -> Draw ()
render_dot fs x y = draw_subroutine alt $ do
  arc x y (dotradius fs) 0 360
  fill (foregroundcolor fs)
  where
    alt = [custom_ps $ printf "%f %f dot\n" x y]

-- | @'render_circle' x y@: Draw an empty control dot at
-- (/x/,/y/).
render_circle :: FormatStyle -> X -> Y -> Draw ()
render_circle fs x y = draw_subroutine alt $ do
  arc x y (dotradius fs) 0 360
  fillstroke (backgroundcolor fs)
  where
    alt = [custom_ps $ printf "%f %f circ\n" x y]

-- | @'render_not' x y@: Draw a \"not\" gate at (/x/,/y/).
render_not :: FormatStyle -> X -> Y -> Draw ()
render_not fs x y = draw_subroutine alt $ do
  arc x y (oplusradius fs) 0 360
  fillstroke (backgroundcolor fs)
  render_line (x-(oplusradius fs)) y (x+(oplusradius fs)) y
  render_line x (y-(oplusradius fs)) x (y+(oplusradius fs))
  where
    alt = [custom_ps $ printf "%f %f oplus\n" x y]

-- | @'render_swap' x y@: Draw a cross (swap gate component) at
--  (/x/,/y/).
render_swap :: FormatStyle -> X -> Y -> Draw ()
render_swap fs x y = draw_subroutine alt $ do
  render_line (x-(crossradius fs)) (y-(crossradius fs)) (x+(crossradius fs)) (y+(crossradius fs))
  render_line (x-(crossradius fs)) (y+(crossradius fs)) (x+(crossradius fs)) (y-(crossradius fs))
  where  
    alt = [custom_ps $ printf "%f %f cross\n" x y]

-- | @'render_bar' x y@: Draw an init/term bar at (/x/,/y/).
render_bar :: FormatStyle -> X -> Y -> Draw ()
render_bar fs x y = draw_subroutine alt $ do
  rectangle (x - (barwidth fs)/2) (y - (barheight fs)/2) (barwidth fs) (barheight fs)
  fill (foregroundcolor fs)
  where
    alt = [custom_ps $ printf "%f %f bar\n" x y]

-- | @'render_bar' x y@: Draw a dterm bar at (/x/,/y/).
render_dbar :: FormatStyle -> X -> Y -> Draw ()
render_dbar fs x y = draw_subroutine alt $ do
  block $ do
    translate (x+(barwidth fs)/2) y
    scale (dwidth fs) (dheight fs)
    moveto (-1) (-0.5)
    arc_append (-0.5) 0 0.5 (-90) 90
    lineto (-1) 0.5
    closepath
    fill (foregroundcolor fs)
  where
    alt = [custom_ps $ printf "%f %f dbar\n" x y]

-- | @'render_init' name x y@: Draw an \"init\" gate at
-- (/x/,/y/), with state /name/.
render_init :: FormatStyle -> String -> X -> Y -> Draw ()
render_init fs name x y = draw_subroutine alt $ do
  render_bar fs x y
  textbox align_right (gatefont fs) (foregroundcolor fs) (x-(xoff fs)/2+(gatepad fs)/2) y (x-(gatepad fs)/2) y (stringbase fs) name
  where
    alt = [custom_ps $ printf "(%s) %f %f init\n" (ps_escape name) x y]

-- | @'render_term' name x y@: Draw a \"term\" gate at
-- (/x/,/y/), with state /name/.
render_term :: FormatStyle -> String -> X -> Y -> Draw ()
render_term fs name x y = draw_subroutine alt $ do
  render_bar fs x y
  textbox align_left (gatefont fs) (foregroundcolor fs) (x+(gatepad fs)/2) y (x+(xoff fs)/2-(gatepad fs)/2) y (stringbase fs) name
  where
    alt = [custom_ps $ printf "(%s) %f %f term\n" (ps_escape name) x y]

-- | @'render_dterm' name x y@: Draw a \"dterm\" gate at
-- (/x/,/y/), with state /name/.
render_dterm :: FormatStyle -> String -> X -> Y -> Draw ()
render_dterm fs name x y = draw_subroutine alt $ do
  render_dbar fs x y
  textbox align_left (gatefont fs) (foregroundcolor fs) (x+(gatepad fs)/2) y (x+(xoff fs)/2-(gatepad fs)/2) y (stringbase fs) name
  where
    alt = [custom_ps $ printf "(%s) %f %f dterm\n" (ps_escape name) x y]

-- | @'render_namedgate' name inv x y@: draw a named box centered at
-- (/x/,/y/). If /inv/ = 'True', append an \"inverse\" symbol to the
-- end of the name.
render_namedgate :: FormatStyle -> String -> InverseFlag -> X -> Y -> Draw ()
render_namedgate fs name inv x y = draw_subroutine alt $ do
  rectangle (x-gatewidth/2) (y-(gateheight fs)/2) gatewidth (gateheight fs)
  fillstroke (backgroundcolor fs)
  textbox align_center (gatefont fs) (foregroundcolor fs) (x-labelwidth/2) y (x+labelwidth/2) y (stringbase fs) name'
  where
    alt = [custom_ps $ printf "(%s) %f %f gate\n" (ps_escape name') x y]
    name' = name ++ optional inv "*"
    w = text_width (gatefont fs) name'
    labelwidth = min w (maxgatelabelwidth fs)
    gatewidth = labelwidth + (gatepad fs)
            
-- | @'render_gphasegate' name x y@: draw a global phase gate
-- centered at (/x/,/y/).
render_gphasegate :: FormatStyle -> String -> X -> Y -> Draw ()
render_gphasegate fs name x y = draw_subroutine alt $ do
  render_circgate fs name x (y-0.5)
  where
    alt = [custom_ps $ printf "(%s) %f %f gphase\n" (ps_escape name) x y]

-- | @'render_circgate' name x y@: draw a named oval centered at
-- (/x/,/y/).
render_circgate :: FormatStyle -> String -> X -> Y -> Draw ()
render_circgate fs name x y = draw_subroutine alt $ do
  oval x y (0.5*gatewidth) (0.4*(gateheight fs))
  fillstroke (backgroundcolor fs)
  textbox align_center (gatefont fs) (foregroundcolor fs) (x-labelwidth/2) y (x+labelwidth/2) y (stringbase fs) name
  where
    alt = [custom_ps $ printf "(%s) %f %f circgate\n" (ps_escape name) x y]
    w = text_width (gatefont fs) name
    labelwidth = min w (maxgatelabelwidth fs)
    gatewidth = labelwidth + (gatepad fs)
    
-- | @'render_blankgate' name x y@: draw an empty box centered
-- at (/x/,/y/), big enough to hold /name/.
render_blankgate :: FormatStyle -> String -> X -> Y -> Draw ()
render_blankgate fs name x y = draw_subroutine alt $ do
  rectangle (x-gatewidth/2) (y-(gateheight fs)/2) gatewidth (gateheight fs)
  fillstroke (backgroundcolor fs)
  where
    alt = [custom_ps $ printf "(%s) %f %f box\n" (ps_escape name) x y]
    w = text_width (gatefont fs) name
    labelwidth = min w (maxgatelabelwidth fs)
    gatewidth = labelwidth + (gatepad fs)

-- | @'render_comment' center s x y m@: draw the given string
-- vertically, with the top of the string near the given
-- /y/-coordinate. If /center/=='True', center it at the
-- /x/-coordinate, else move it just to the left of the
-- /x/-coordinate. /m/ is the maximum height allowed for the comment.
render_comment :: FormatStyle -> Bool -> String -> X -> Y -> Y -> Draw ()
render_comment fs center s x y maxh = draw_subroutine alt $ do
  textbox align_right (commentfont fs) (commentcolor fs) x (y-maxh) x (y+0.4) b s
  where
    alt = [custom_ps $ printf "(%s) %f %f %f %f comment\n" (ps_escape s) x y maxh yshift]
    b = if center then 0.15 else -0.25
    yshift = -b * nominalsize (commentfont fs)

-- | @'render_label' center s x y@: draw the given label just above
-- the given point. If /center/=='True', center it at the
-- /x/-coordinate, else move it just to the right of the
-- /x/-coordinate.
render_label :: FormatStyle -> Bool -> String -> X -> Y -> Draw ()
render_label fs True s x y = draw_subroutine alt $ do
  textbox align_center (labelfont fs) (labelcolor fs) (x-(maxlabelwidth fs)) y' (x+(maxlabelwidth fs)) y' (-0.5) s
  where
    alt = [custom_ps $ printf "(%s) %f %f clabel\n" (ps_escape s) x y']
    y' = y + 0.5 * (coffs fs)
render_label fs False s x y = draw_subroutine alt $ do
  textbox align_left (labelfont fs) (labelcolor fs) x y' (x+(maxlabelwidth fs)) y' (-0.5) s
  where
    alt = [custom_ps $ printf "(%s) %f %f rlabel\n" (ps_escape s) x y']
    y' = y + 0.5 * (coffs fs)
    
-- | Render the number at the given point (/x/,/y/). If the boolean
-- argument is 'True', put the number to the right of /x/, else to the left. 
render_number :: FormatStyle -> Int -> Bool -> X -> Y -> Draw ()
render_number fs i True x y = draw_subroutine alt $ do
  textbox align_left (numberfont fs) (numbercolor fs) (x+0.2) y (x+0.2+(maxnumberwidth fs)) y (stringbase fs) (show i)
  where
    alt = [custom_ps $ printf "(%s) %f %f rnumber\n" (ps_escape (show i)) x y]
render_number fs i False x y = draw_subroutine alt $ do
  textbox align_right (numberfont fs) (numbercolor fs) (x-0.2-(maxnumberwidth fs)) y (x-0.2) y (stringbase fs) (show i)
  where
    alt = [custom_ps $ printf "(%s) %f %f lnumber\n" (ps_escape (show i)) x y]

-- ----------------------------------------------------------------------
-- ** Higher-level rendering functions

-- | Render a horizontal wire from /x/-coordinates /oldx/ to /x/,
-- using /t/ as the type and figuring out the /y/-coordinate from /ys/
-- and /w/. Append to the given string. If the parameters are invalid
-- (/w/ not in /ys/), throw an error.
render_typeas :: FormatStyle -> Map Wire Y -> X -> X -> Wire -> Wiretype -> Draw ()
render_typeas fs ys oldx x w t =
  let y = ys Map.! w in
  case t of
    Qbit -> do
      render_line oldx y x y
    Cbit -> do
      render_line oldx (y + (coffs fs)) x (y + (coffs fs))
      render_line oldx (y - (coffs fs)) x (y - (coffs fs))

-- | Render a bunch of horizontal wires from their repective starting
-- 'Xarity' to /x/.
render_xarity :: FormatStyle -> Map Wire Y -> Xarity -> X -> Draw ()
render_xarity fs ys xarity x = do
  sequence_ [ render_typeas fs ys oldx x w t | (w,(t,oldx)) <- Map.toList xarity ]

-- | Format a floating point number in concise form, with limited
-- accuracy.
dshow :: Double -> String
dshow dbl = 
  if abs dbl < 0.01 
  then
    printf "%.1e" dbl
  else
    (reverse . strip . reverse) (printf "%.3f" dbl)
      where
        strip [] = []
        strip ('.' : t) = t
        strip ('0' : t) = strip t
        strip t = t
        
-- | @'render_controlwire' /x/ /ys/ /ws/ /c/@: 
-- Render the line connecting all the box components and all the
-- control dots of some gate. 
-- 
-- Parameters: /x/ is the current /x/-coordinate, /ys/ is an indexed
-- array of /y/-coordinates, /ws/ is the set of wires for boxes, and
-- /c/ is a list of controls.
render_controlwire :: X -> Map Wire Y -> [Wire] -> Controls -> Draw ()
render_controlwire x ys ws c =
  case ws of
    [] -> return ()
    w:ws -> render_line x y0 x y1      
      where
        ymap w = ys Map.! w
        y = ymap w
        cy = map (\(Signed w _) -> ymap w) c
        yy = map (\w -> ymap w) ws
        y0 = foldr min y (cy ++ yy)
        y1 = foldr max y (cy ++ yy)

-- | @'render_controlwire_float' /x/ /ys/ /y/ /c/@: Render the line
-- connecting all control dots of the given controls, as well as a
-- floating \"global phase\" gate located just below (/x/, /y/). 
-- 
-- Parameters: /x/ is the current /x/-coordinate, /ys/ is an indexed
-- array of /y/-coordinates, /y/ is the /y/-coordinate of the wire
-- where the floating gate is attached, and /c/ is a list of controls.
render_controlwire_float :: X -> Map Wire Y -> Y -> Controls -> Draw ()
render_controlwire_float x ys y c = render_line x y0 x y1 
  where
    y' = y - 0.5
    cy = map (\(Signed w _) -> ys Map.! w) c
    y0 = minimum (y':cy)
    y1 = maximum (y':cy)

-- | @'render_controldots' /x/ /ys/ /c/@: Render the control dots
-- for the given controls.
render_controldots :: FormatStyle -> X -> Map Wire Y -> Controls -> Draw ()
render_controldots fs x ys c = do
  sequence_ [ renderdot x | x <- c ]
  where
    renderdot (Signed w True) = render_dot fs x (ys Map.! w)
    renderdot (Signed w False) = render_circle fs x (ys Map.! w)

-- | @'render_multi_gate' /x/ /ys/ /name/ /inv/ /wires/@: Render the
-- boxes for an /n/-ary gate of the given /name/, potentially
-- /inv/erted, at the given list of /wires/. The first two arguments
-- are the current /x/-coordinate and an indexed array of
-- /y/-coordinates.
render_multi_gate :: FormatStyle -> X -> Map Wire Y -> String -> InverseFlag -> [Wire] -> Draw ()
render_multi_gate fs x ys name inv [w] = 
  render_namedgate fs name inv x (ys Map.! w)
render_multi_gate fs x ys name inv ws =
  sequence_ [ render_namedgate fs (name ++ " " ++ show i) inv x (ys Map.! a) | (a,i) <- zip ws [1..] ]

-- | @'render_multi_named_ctrl' /x/ /ys/ /wires/ /names/@: Render
-- the boxes for multiple generalized controls at the given /wires/,
-- using the given /names/. We take special care of the fact that
-- generalized controls may be used non-linearly. 
render_multi_named_ctrl :: FormatStyle -> X -> Map Wire Y -> [Wire] -> [String] -> Draw ()
render_multi_named_ctrl fs x ys ws names =
  sequence_ [ render_circgate fs name x (ys Map.! a) | (a,name) <- IntMap.toList map ]
  where
    -- Combine the labels for w if w has multiple occurrences.
    map = IntMap.fromListWith (\x y -> y ++ "," ++ x) (zip ws names)

-- | @'render_multi_genctrl' /x/ /ys/ /wires/@: Render the boxes for
-- multiple (numbered) generalized controls at the given /wires/.
render_multi_genctrl :: FormatStyle -> X -> Map Wire Y -> [Wire] -> Draw ()
render_multi_genctrl fs x ys ws = render_multi_named_ctrl fs x ys ws names
  where
    names = map show [1..]
            
-- | Number a list of wires in increasing order, at the given
-- /x/-coordinate. If the boolean argument is 'True', put the numbers
-- to the right of /x/, else to the left.
render_ordering :: FormatStyle -> X -> Map Wire Y -> Bool -> [Wire] -> Draw ()
render_ordering fs x ys b ws =
  sequence_ [ render_number fs i b x (ys Map.! w) | (w,i) <- numbering ]
  where
    numbering = zip ws [1..]

-- | Render gate /g/ at /x/-coordinate /x/ and /y/-coordinates as
-- given by /ys/, which is a map from wires to
-- /y/-coordinates. Returns a pair (/s/,/t/) of draw actions for
-- background and foreground, respectively.
render_gate :: FormatStyle -> Gate -> X -> Map Wire Y -> Y -> (Draw (), Draw ())
render_gate fs g x ys maxh =
  let ymap w = ys Map.! w 
  in
  case g of
    -- Certain named gates are recognized for custom rendering.
    QGate "not" _ [w] [] c ncf -> (s2, t2 >> t3)
      where
        y = ymap w
        s2 = render_controlwire x ys [w] c
        t2 = render_controldots fs x ys c
        t3 = (render_not fs x y)
    QGate "multinot" _ ws [] c ncf -> (s2, t2 >> t3)
      where
        s2 = render_controlwire x ys ws c
        t2 = render_controldots fs x ys c
        t3 = sequence_ (map (\w -> (render_not fs x (ymap w))) ws)
    QGate "swap" _ [w1,w2] [] c ncf -> (s2, t2 >> t3)
      where
        y1 = ymap w1
        y2 = ymap w2
        s2 = render_controlwire x ys [w1,w2] c
        t2 = render_controldots fs x ys c
        t3 = (render_swap fs x y1) >> (render_swap fs x y2)
    QGate "trace" _ _ _ _ _ -> (return (), return ())
    QGate name inv ws1 ws2 c ncf -> (s2, t2 >> t3 >> t4)
      where
       s2 = render_controlwire x ys (ws1 ++ ws2) c
       t2 = render_multi_gate fs x ys name inv' ws1
       t3 = render_controldots fs x ys c
       t4 = render_multi_genctrl fs x ys ws2
       inv' = inv && not (self_inverse name ws1 ws2)
    QRot name inv theta ws1 ws2 c ncf -> (s2, t2 >> t3 >> t4)
      where
       s2 = render_controlwire x ys (ws1 ++ ws2) c
       t2 = render_multi_gate fs x ys name' inv ws1
       t3 = render_controldots fs x ys c
       t4 = render_multi_genctrl fs x ys ws2
       name' = substitute name '%' (dshow theta)
    GPhase t ws c ncf -> (s2, t2 >> t3)
      where
        y = case (ws, c) of
          ([], []) -> maximum (0.0 : Map.elems ys)
          ([], c)  -> minimum [ ymap w | Signed w b <- c ]
          (ws, c)  -> minimum [ ymap w | w <- ws ]
        s2 = render_controlwire_float x ys y c
        t2 = render_controldots fs x ys c
        t3 = (render_gphasegate fs (dshow t) x y)
    CNot w c ncf -> (s2, t2 >> t3)
      where
        y = ymap w
        s2 = render_controlwire x ys [w] c
        t2 = render_controldots fs x ys c
        t3 = (render_not fs x y)
    CGate "if" w [a,b,c] ncf -> (s2, t1 >> t3)  -- special case
      where
       y = ymap w
       s2 = render_controlwire x ys [w,a,b,c] []
       t1 = render_multi_named_ctrl fs x ys [a,b,c] ["if", "then", "else"]
       t3 = render_namedgate fs ">" False x y
    CGateInv "if" w [a,b,c] ncf -> (s2, t1 >> t3)  -- special case
      where
       y = ymap w
       s2 = render_controlwire x ys [w,a,b,c] []
       t1 = render_multi_named_ctrl fs x ys [a,b,c] ["if", "then", "else"]
       t3 = render_namedgate fs "<" False x y
    CGate name w c ncf -> (s2, t2 >> t3)
      where
       y = ymap w
       s2 = render_controlwire x ys (w:c) []
       t2 = render_multi_named_ctrl fs x ys c [ "  " | a <- c ]
       t3 = render_namedgate fs name False x y
    CGateInv name w c ncf -> (s2, t2 >> t3)
      where
       y = ymap w
       s2 = render_controlwire x ys (w:c) []
       t2 = render_multi_named_ctrl fs x ys c [ "  " | a <- c ]
       t3 = render_namedgate fs name True x y
    CSwap w1 w2 c ncf -> (s2, t2 >> t3)
      where
        y1 = ymap w1
        y2 = ymap w2
        s2 = render_controlwire x ys [w1,w2] c
        t2 = render_controldots fs x ys c
        t3 = (render_swap fs x y1) >> (render_swap fs x y2)
    QPrep w ncf -> (return (), t3)
      where
        y = ymap w
        t3 = (render_namedgate fs "prep" False x y)
    QUnprep w ncf -> (return (), t3)
      where
        y = ymap w
        t3 = (render_namedgate fs "unprep" False x y)
    QInit b w ncf -> (return (), t3)
      where
        y = ymap w
        t3 = (render_init fs (if b then "1" else "0") x y)
    CInit b w ncf -> (return (), t3)
      where
        y = ymap w
        t3 = (render_init fs (if b then "1" else "0") x y)
    QTerm b w ncf -> (return (), t3)
      where
        y = ymap w
        t3 = (render_term fs (if b then "1" else "0") x y)
    CTerm b w ncf -> (return (), t3)
      where
        y = ymap w
        t3 = (render_term fs (if b then "1" else "0") x y)
    QMeas w -> (return (), t3)
      where
        y = ymap w
        t3 = (render_namedgate fs "meas" False x y)
    QDiscard w -> (return (), t3)
      where
        y = ymap w
        t3 = (render_bar fs x y)
    CDiscard w -> (return (), t3)
      where
        y = ymap w
        t3 = (render_bar fs x y)
    DTerm b w -> (return (), t3)
      where
        y = ymap w
        t3 = (render_dterm fs (if b then "1" else "0") x y)
    Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep -> (s2, t2 >> t3)
      where
       ws = union ws1 ws2
       s2 = render_controlwire x ys ws c
       t2 = render_multi_gate fs x ys label inv ws
       t3 = render_controldots fs x ys c
       show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")"
       BoxId name shape = boxid
       label = name ++ show_rep ++ if (subroutineshape fs) then (", shape " ++ shape) else ""
    Comment s inv ws -> (return (), t1 >> t2)
      where
        t1 = render_comment fs (null ws) s' x (ymap 0) maxh
        t2 = sequence_ [render_label fs (null s) l x (ymap w) | (w,l) <- ws]
        s' = s ++ optional inv "*"

-- | Render the gates in the circuit. The parameters are: /xarity/:
-- the 'Xarity' of the currently pending wires. /xgs/: the list of
-- gates, paired with pre-computed /x/-coordinates. /ys/: a map from
-- wires to pre-computed /y/-coordinates. /x/: the right-most
-- /x/-coordinate where the final wires will be drawn to. /maxh/: the
-- maximal height of comments.
render_gates :: FormatStyle -> Xarity -> [(Gate, X)] -> Map Wire Y -> X -> Y -> (Draw (), Draw ())
render_gates fs xarity xgs ys x maxh =
  case xgs of
    [] ->
      let s2 = render_xarity fs ys xarity x
      in (s2, return ())
    (g,newx):gls ->
      let (xarity_term, xarity_new) = update_xarity xarity g newx in
      let s1 = render_xarity fs ys xarity_term newx in
      let (s2, t2) = render_gate fs g newx ys maxh in
      let (sx, tx) = render_gates fs xarity_new gls ys x maxh in
      (s1 >> s2 >> sx, t2 >> tx)

-- | PostScript definitions of various parameters.
ps_parameters :: FormatStyle -> String
ps_parameters fs =
  "% some parameters\n"
  ++ printf "%f setlinewidth\n" (linewidth fs)
  ++ printf "/gatepad %f def\n" (gatepad fs)
  ++ printf "/gateheight %f def\n" (gateheight fs)
  ++ printf "/stringbase %f def\n" (stringbase fs)
  ++ printf "/dotradius %f def\n" (dotradius fs)
  ++ printf "/oplusradius %f def\n" (oplusradius fs)
  ++ printf "/crossradius %f def\n" (crossradius fs)
  ++ printf "/barwidth %f def\n" (barwidth fs)
  ++ printf "/barheight %f def\n" (barheight fs)
  ++ printf "/dwidth %f def\n" (dwidth fs)
  ++ printf "/dheight %f def\n" (dheight fs)
  ++ printf "/maxgatelabelwidth %f def\n" (maxgatelabelwidth fs)
  ++ printf "/maxlabelwidth %f def\n" (maxlabelwidth fs)
  ++ printf "/maxnumberwidth %f def\n" (maxnumberwidth fs)
  ++ "/gatefont { /Times-Roman findfont .5 scalefont setfont } def\n"
  ++ "/labelfont { /Times-Roman findfont .3 scalefont setfont } def\n"
  ++ "/commentfont { /Times-Roman findfont .3 scalefont setfont } def\n"
  ++ "/numberfont { /Times-Roman findfont .5 scalefont setfont } def\n"
  ++ "/labelcolor { 0 0 1 setrgbcolor } def\n"
  ++ "/commentcolor { 1 0.2 0.2 setrgbcolor } def\n"
  ++ "/numbercolor { 0 0.7 0 setrgbcolor } def\n"

-- | PostScript definitions for various drawing subroutines. The
-- subroutines provided are:
-- 
-- > x0 y0 x1 y1 line       : draw a line from (x0,y0) to (x1,y1)
-- > x0 y0 x1 y1 dashedline : draw a dashed line from (x0,y0) to (x1,y1)
-- > x y h w rect           : draw a rectangle of dimensions w x h centered at (x,y)
-- > x y h w oval           : draw an oval of dimensions w x h centered at (x,y)
-- > x y dot           : draw a filled dot at (x,y)
-- > x y circ          : draw an empty dot at (x,y)
-- > x y oplus         : draw a "not" gate at (x,y)
-- > x y cross         : draw a cross ("swap" gate component) at (x,y)
-- > x y bar           : draw an init/term bar at (x,y)
-- > x y dbar          : draw a dterm bar at (x,y)
-- > name x y box      : draw an empty box at (x,y), big enough to fit name
-- > name x y gate     : draw a named box at (x,y)
-- > name x y circgate : draw a named round box at (x,y)
-- > name x y gphase   : draw a global phase gate (x,y)
-- > b x y init        : draw an "init" gate at (x,y), with state b
-- > b x y term        : draw a "term" gate at (x,y), with state b
-- > b x y dterm       : draw a "dterm" gate at (x,y), with state b
-- > string x y m b comment : draw a vertical comment at (x,y), with max height m and baseline adjustment b
-- > string x y clabel      : draw a wire label at (x,y), x-centered
-- > string x y rlabel      : draw a wire label at (x,y), right of x
-- > string x y lnumber     : draw a numbered input at (x,y)
-- > string x y rnumber     : draw a numbered output at (x,y)

ps_subroutines :: String
ps_subroutines = 
    "% subroutine definitions\n"
    ++ "/line { moveto lineto stroke } bind def\n"
    ++ "/dashedline { moveto gsave [0.3 0.2] .15 setdash lineto stroke grestore } bind def\n"
    ++ "/rect { /H exch def /W exch def -.5 W mul .5 H mul moveto W 0 rlineto 0 H neg rlineto W neg 0 rlineto closepath } bind def\n"
    ++ "/oval { /H exch def /W exch def gsave .5 W mul .5 H mul scale 0 0 1 0 360 newpath arc gsave 1.0 setgray fill grestore stroke grestore } bind def\n"
    ++ "/dot { dotradius 0 360 newpath arc gsave 0 setgray fill grestore newpath } bind def\n"
    ++ "/circ { dotradius 0 360 newpath arc gsave 1.0 setgray fill grestore stroke } bind def\n"
    ++ "/oplus { gsave translate 0 0 oplusradius 0 360 newpath arc gsave 1.0 setgray fill grestore stroke 0 oplusradius neg 0 oplusradius line oplusradius neg 0 oplusradius 0 line grestore } bind def\n"
    ++ "/cross { gsave translate crossradius dup dup neg dup line crossradius dup neg dup dup neg line grestore } bind def\n"
    ++ "/bar { gsave translate barwidth barheight rect fill grestore } bind def\n"
    ++ "/dbar { gsave translate barwidth 0.5 mul 0 translate dwidth dheight scale -1 -.5 moveto -.5 0 .5 -90 90 arc -1 .5 lineto closepath fill grestore } bind def\n"
    ++ "/box { gsave translate gatefont stringwidth pop /w exch def /w1 w gatepad add def w1 gateheight rect gsave 1.0 setgray fill grestore stroke grestore } bind def\n"
    ++ "/gate { gsave translate dup gatefont stringwidth pop /w exch def /fontscale w maxgatelabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def /w2 w fontscale div def /w1 w2 gatepad add def w1 gateheight rect gsave 1.0 setgray fill grestore stroke 1 fontscale div dup scale 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"
    ++ "/circgate { gsave translate dup gatefont stringwidth pop /w exch def /fontscale w maxgatelabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def /w2 w fontscale div def /w1 w2 gatepad add def w1 0.8 gateheight mul oval gsave 1.0 setgray fill grestore stroke 1 fontscale div dup scale 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"
    ++ "/gphase { gsave translate 0 -0.5 circgate grestore } bind def\n"
    ++ "/init { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def -.5 w1 mul 0 translate 0.5 w1 mul 0 bar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"
    ++ "/term { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def .5 w1 mul 0 translate -0.5 w1 mul 0 bar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"
    ++ "/dterm { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def .5 w1 mul 0 translate -0.5 w1 mul 0 dbar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"
    ++ "/comment { gsave /b exch def /maxh exch def /y exch def /x exch def commentfont commentcolor x y maxh sub x y 0.4 add 1.0 b textbox grestore } bind def\n"
    ++ "/clabel { gsave translate dup labelfont stringwidth pop /w exch def /fontscale w maxlabelwidth 2 mul div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0 0.15 translate 1 fontscale div dup scale -0.5 w mul 0 moveto labelcolor show grestore } bind def\n"
    ++ "/rlabel { gsave translate dup labelfont stringwidth pop /w exch def /fontscale w maxlabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0 0.15 translate 1 fontscale div dup scale 0 0 moveto labelcolor show grestore } bind def\n"
    ++ "/lnumber { gsave translate dup numberfont stringwidth pop /w exch def /fontscale w maxnumberwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def -0.2 -0.15 translate 1 fontscale div dup scale -1 w mul 0 moveto numbercolor show grestore } bind def\n"
    ++ "/rnumber { gsave translate dup numberfont stringwidth pop /w exch def /fontscale w maxnumberwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0.2 -0.15 translate 1 fontscale div dup scale 0 0 moveto numbercolor show grestore } bind def\n"
      
-- | @'page_of_ocircuit' name ocirc@: Render the circuit /ocirc/ on a
-- single page.
-- 
-- The rendering takes place in the following user coordinate system:
-- 
-- \[image coord.png]
page_of_ocircuit :: FormatStyle -> Maybe BoxId -> OCircuit -> Document ()
page_of_ocircuit fs boxid ocirc = do
  newpage bboxx bboxy $ do
    when (isJust boxid) $ do
      comment ("drawing commands for " ++ string_of_boxid (fromJust boxid))
    
    -- set up the user coordinate system
    scale sc sc
    translate ((xoff fs) + 1) 1
    
    -- drawing commands
    setlinewidth (linewidth fs)
    when (isJust boxid) $ do
      textbox align_left (gatefont fs) (foregroundcolor fs) (-(xoff fs)) (raw_height-0.25) raw_width (raw_height-0.25) (stringbase fs) ("Subroutine " ++ string_of_boxid (fromJust boxid) ++ ":")
    rendered_wires
    rendered_gates
    render_ordering fs (-(xoff fs)) ys False w_in
    render_ordering fs raw_width ys True w_out
  where
    -- unit scale: distance, in points, between wires
    sc = 10
    
    -- decompose OCircuit
    OCircuit (w_in, circ, w_out) = ocirc
    (a1,gs,a2,_) = circ
    
    -- figure out y-coordinates and height
    ws = wirelist_of_circuit circ
    raw_height = fromIntegral $ length ws
    ys = Map.fromList (zip (reverse ws) [0.0 ..])
    maxh = raw_height + 0.3
    bboxy = sc * (raw_height + 1)
    
    -- figure out x-coordinates and width
    (raw_width,xgs) = assign_x_coordinates fs gs 0.0
    bboxx = sc * (raw_width + (xoff fs) + 2.0)
    
    xa1 = IntMap.map (\t -> (t, -(xoff fs))) a1
    (rendered_wires, rendered_gates) = render_gates fs (Map.fromList (IntMap.assocs xa1)) xgs ys raw_width maxh

-- | Render a low-level boxed quantum circuit as a graphical
-- 'Document'. If there are subroutines, each of them is placed on a
-- separate page.
render_bcircuit :: FormatStyle -> BCircuit -> Document ()
render_bcircuit fs (circ, namespace) = do
  page_of_ocircuit fs Nothing (OCircuit ([], circ, []))
  sequence_ [ page_of_ocircuit fs (Just boxid) ocirc | (boxid, TypedSubroutine ocirc _ _ _) <- Map.toList namespace]

-- | Render a low-level dynamic quantum circuit as a graphical
-- 'Document'. If there are subroutines, each of them is placed on a
-- separate page.  If the circuit uses dynamic lifting, an error is
-- produced.
render_dbcircuit :: FormatStyle -> ErrMsg -> DBCircuit a -> Document ()
render_dbcircuit fs e dbcirc = render_bcircuit fs bcirc where
  (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc
  errmsg x = e ("operation not permitted during graphical rendering: " ++ x)

-- | Print a representation of a low-level quantum circuit, in the
-- requested graphics format, directly to standard output. If there
-- are boxed subcircuits, each of them is placed on a separate page.
print_bcircuit_format :: FormatStyle -> BCircuit -> IO ()
print_bcircuit_format fs bcirc =
  render_custom_stdout (renderformat fs) cust (render_bcircuit fs bcirc)
    where
      cust = custom {
        creator = "Quipper",
        ps_defs = ps_parameters fs ++ ps_subroutines 
        }

-- | Print a representation of a low-level dynamic quantum circuit, in
-- the requested graphics format, directly to standard output. If
-- there are boxed subcircuits, each of them is placed on a separate
-- page. If the circuit uses dynamic lifting, an error is produced.
print_dbcircuit_format :: FormatStyle -> ErrMsg -> DBCircuit a -> IO ()
print_dbcircuit_format fs e dbcirc = 
  render_custom_stdout (renderformat fs) cust (render_dbcircuit fs e dbcirc)
    where 
      cust = custom {
        creator = "Quipper",
        ps_defs = ps_parameters fs ++ ps_subroutines
        }

-- ----------------------------------------------------------------------
-- * Interface to external programs

-- | @'system_pdf_viewer' zoom pdffile@: Call a system-specific PDF
-- viewer on /pdffile/ file. The /zoom/ argument is out of 100 and may
-- or may not be ignored by the viewer.
system_pdf_viewer :: Double -> String -> IO ()
system_pdf_viewer zoom pdffile = do
  envList <- getEnvironment
  if (List.elem ("OS", "Windows_NT") envList)
  then do
    rawSystem "acroread.bat" [pdffile]
  else if (os == "darwin")
  then do
    rawSystem "open" [pdffile]
    rawSystem "sleep" ["1"] -- required or the file may be deleted too soon
  else do
    rawSystem "acroread" ["/a", "zoom=100", pdffile]
  return ()

-- ----------------------------------------------------------------------
-- * Previewing

-- | Display a document directly in Acrobat Reader. This may not be
-- portable. It requires the external program \"acroread\" to be
-- installed.
preview_document :: Document a -> IO a
preview_document = preview_document_custom custom

-- | Display a document directly in Acrobat Reader. This may not be
-- portable. It requires the external program \"acroread\" to be
-- installed.
preview_document_custom :: Custom -> Document a -> IO a
preview_document_custom custom doc = do
  tmpdir <- getTemporaryDirectory
  (pdffile, fd) <- openTempFile tmpdir "Quipper.pdf"
  a <- render_custom_file fd Format_PDF custom doc
  hClose fd
  system_pdf_viewer 100 pdffile
  removeFile pdffile
  return a

-- | Display the circuit directly in Acrobat Reader. This may not be
-- portable. It requires the external program \"acroread\" to be
-- installed.
preview_bcircuit :: BCircuit -> IO ()
preview_bcircuit bcirc =
  preview_document doc
  where
    doc = render_bcircuit pdf bcirc

-- | Display a low-level dynamic quantum circuit directly in Acrobat
-- Reader. This may not be portable. It requires the external program
-- \"acroread\" to be installed. If the circuit uses dynamic lifting,
-- an error is produced.
preview_dbcircuit :: ErrMsg -> DBCircuit a -> IO ()
preview_dbcircuit e dbcirc = preview_bcircuit bcirc where
  (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc
  errmsg x = e ("operation not permitted for PDF preview: " ++ x)

-- ----------------------------------------------------------------------
-- * Gate counts

-- ** Gate types

-- $ The type 'Gate' contains too much information to be used as the 
-- index for counting gates: all 'CNot' gates, for instance,
-- should be counted together, regardless of what wires they are
-- applied to.
--
-- We define 'Gatetype' to remedy this, with each value of 
-- 'Gatetype' corresponding to an equivalence class of
-- gates as they should appear in gate counts.
--
-- During gate counting, a little more information needs to be retained,
-- so that operations such as adding controls to subroutine counts can
-- be accurately performed.  'AnnGatetype' supplies this information.

-- | An abbreviated representation of the controls of a gate: 
-- the number of positive and negative controls, respectively.
type ControlType = (Int,Int) 

-- | From a list of controls, extract the number of positive and
-- negative controls.
controltype :: Controls -> ControlType
controltype c =
  (length $ filter get_sign c, length $ filter (not . get_sign) c)

-- | Convenience constant for uncontrolled gates.
nocontrols :: ControlType
nocontrols = (0,0)

-- | A data type representing equivalence classes of basic gates,
-- for the output of gatecounts.
data Gatetype = 
  Gatetype String ControlType
  | GatetypeSubroutine BoxId InverseFlag ControlType
 deriving (Eq, Ord, Show)

-- | A data type analogous to 'Gatetype', but with extra annotations,
-- e.g. a 'NoControlFlag', for use in the computation of gate counts.
data AnnGatetype = 
    AnnGatetype String (Maybe String) ControlType NoControlFlag ControllableFlag
  | AnnGatetypeSubroutine BoxId InverseFlag ControlType NoControlFlag ControllableFlag
  deriving (Eq, Ord, Show)

-- | Forget the annotations of an 'AnnGatetype'
unannotate_gatetype :: AnnGatetype -> Gatetype
unannotate_gatetype (AnnGatetype n _ cs _ _) = Gatetype n cs
unannotate_gatetype (AnnGatetypeSubroutine n i cs _ _) = GatetypeSubroutine n i cs

-- | Add controls to an annotated gate type, or throw an error message if it is not controllable; 
-- unless its 'NoControlFlag' is set, in which case leave it unchanged.
add_controls_gatetype :: ErrMsg -> ControlType -> AnnGatetype -> AnnGatetype
add_controls_gatetype e (x',y') g@(AnnGatetype n n_inv (x,y) ncf cf) =
  if ncf then g
  else case cf of
     AllCtl           -> AnnGatetype n n_inv (x+x',y+y') ncf cf
     OnlyClassicalCtl -> AnnGatetype n n_inv (x+x',y+y') ncf cf
     NoCtl            -> error $ e "add_controls_gatetype: gate " ++ n ++ " is not controllable."

add_controls_gatetype e (x',y') g@(AnnGatetypeSubroutine n inv (x,y) ncf cf) =
  if ncf then g
  else case cf of
     AllCtl           -> AnnGatetypeSubroutine n inv (x+x',y+y') ncf cf
     OnlyClassicalCtl -> AnnGatetypeSubroutine n inv (x+x',y+y') ncf cf
     NoCtl            -> error $ e "add_controls_gatetype: subroutine " ++ show n ++ " is not controllable."

-- | Reverse an annotated gate type, of throw an error if it is not reversible. 
reverse_gatetype :: ErrMsg -> AnnGatetype -> AnnGatetype
reverse_gatetype e g@(AnnGatetype n n_inv cs ncf cf) =
  case n_inv of
    Just n' -> (AnnGatetype n' (Just n) cs ncf cf)
    Nothing -> error $ e "reverse_gatetype: gate " ++ n ++ " is not reversible"
reverse_gatetype e g@(AnnGatetypeSubroutine n inv cs ncf cf) =
  (AnnGatetypeSubroutine n (not inv) cs ncf cf)

-- | Set the 'NoControlFlag' of an annotated gate type to 'True'.
set_ncf_gatetype :: AnnGatetype -> AnnGatetype
set_ncf_gatetype (AnnGatetype n n_inv cs ncf cf) =
                 (AnnGatetype n n_inv cs True cf)
set_ncf_gatetype (AnnGatetypeSubroutine n inv cs ncf cf) =
                 (AnnGatetypeSubroutine n inv cs True cf)

-- | Helper function for 'gatetype': append a formatted arity to a string.
with_arity :: String -> Int -> String
n `with_arity` a = n ++ ", arity " ++ show a

-- | Convert a given low-level gate to an annotated gate type
gatetype :: Gate -> AnnGatetype
gatetype (QGate n inv ws vs c ncf) =
  AnnGatetype (n' inv') (Just $ n' $ notinv') (controltype c) ncf AllCtl
  where 
    n' b = (n ++ optional b "*") `with_arity` (length ws + length vs)
    inv' = inv && not (self_inverse n ws vs)
    notinv' = not inv && not (self_inverse n ws vs)
gatetype (QRot n inv t ws vs c ncf) =
  AnnGatetype (n' inv) (Just $ n' $ not inv) (controltype c) ncf AllCtl
  where n' b = (printf "Rot(%s,%f)" (n++ optional b "*") t) `with_arity` (length ws + length vs)
gatetype (GPhase t w c ncf) = 
  AnnGatetype (phase_name t) (Just $ phase_name (-t)) (controltype c) ncf AllCtl
  where phase_name t = (printf "exp^(%f i pi)" t)
gatetype (CNot w c ncf) = 
  AnnGatetype "CNot" (Just "CNot") (controltype c) ncf AllCtl
gatetype (CGate n w ws ncf) = 
  AnnGatetype (n' True) (Just $ n' False) nocontrols ncf AllCtl
  where n' b = n ++ optional b "*" `with_arity` length ws
gatetype (CGateInv n w ws ncf) =
  AnnGatetype (n' False) (Just $ n' True) nocontrols ncf AllCtl
  where n' b = n ++ optional b "*" `with_arity` length ws
gatetype (CSwap w v c ncf) =
  AnnGatetype "CSwap" (Just "CSwap") (controltype c) ncf AllCtl
gatetype (QPrep w ncf) =
  AnnGatetype "Prep" (Just "Unprep") nocontrols ncf NoCtl
gatetype (QUnprep w ncf) = 
  AnnGatetype "Unprep" (Just "Prep") nocontrols ncf NoCtl
gatetype (QInit b w ncf) =
  AnnGatetype ("Init" ++ b') (Just $ "Term" ++ b') nocontrols ncf NoCtl
  where b' = show $ if b then 1 else 0
gatetype (CInit b w ncf) =
  AnnGatetype ("CInit" ++ b') (Just $ "CTerm" ++ b') nocontrols ncf NoCtl
  where b' = show $ if b then 1 else 0
gatetype (QTerm b w ncf) =
  AnnGatetype ("Term" ++ b') (Just $ "Init" ++ b') nocontrols ncf NoCtl
  where b' = show $ if b then 1 else 0
gatetype (CTerm b w ncf) =
  AnnGatetype ("CTerm" ++ b') (Just $ "CInit" ++ b') nocontrols ncf NoCtl
  where b' = show $ if b then 1 else 0
gatetype (QMeas w) = 
  AnnGatetype "Meas" Nothing nocontrols False NoCtl
gatetype (QDiscard w) =
  AnnGatetype "Discard" Nothing nocontrols False NoCtl
gatetype (CDiscard w) =
  AnnGatetype "CDiscard" Nothing nocontrols False NoCtl
gatetype (DTerm b w) =
  AnnGatetype "CDiscard" Nothing nocontrols False NoCtl
gatetype (Subroutine boxid inv ws1 a1 ws2 a2 c ncf ctrble reps) =
  AnnGatetypeSubroutine boxid inv (controltype c) ncf ctrble
gatetype (Comment _ inv ws) = AnnGatetype ("Comment") (Just "Comment") nocontrols True NoCtl

-- | Convert a gate type to a human-readable string.
string_of_gatetype :: Gatetype -> String
string_of_gatetype (Gatetype s (c1,c2)) =
  printf "\"%s\"" s
  ++ if c2==0 && c1==0 then "" else
     if c2==0 then printf ", controls %d" c1 else
     printf " controls %d+%d" c1 c2
string_of_gatetype (GatetypeSubroutine boxid i (c1,c2)) =
  "Subroutine" ++ optional i "*" ++ cs ++ ": " ++ string_of_boxid boxid
  where
    cs = if c2==0 && c1==0 then "" else
         if c2==0 then printf ", controls %d" c1 else
         printf " controls %d+%d" c1 c2

-- ** Gate counts

-- | Gate counts of circuits.  
type Gatecount = Map Gatetype Integer

-- | Annotated gate counts of circuits.  
type AnnGatecount = Map AnnGatetype Integer

-- | Given the (annotated) gatecount of a circuit, return the gatecount of
-- the reverse circuit, or throw an error if any component is not reversible.
reverse_gatecount :: ErrMsg -> AnnGatecount -> AnnGatecount
reverse_gatecount e = Map.mapKeysWith (+) (reverse_gatetype e)

-- | Given the (annotated) gatecount of a circuit, return the gatecount of
-- the same circuit with controls added, or throw an error if any component
-- is not controllable.
add_controls_gatecount :: ErrMsg -> ControlType -> AnnGatecount -> AnnGatecount
add_controls_gatecount e cs = Map.mapKeysWith (+) (add_controls_gatetype e cs)

-- | Set the ncf of all gates in a gatecount to 'True'.
set_ncf_gatecount :: AnnGatecount -> AnnGatecount
set_ncf_gatecount = Map.mapKeysWith (+) set_ncf_gatetype

-- | Remove the annotations from a gatecount.
unannotate_gatecount :: AnnGatecount -> Gatecount
unannotate_gatecount = Map.mapKeysWith (+) unannotate_gatetype

-- | Input a list of items and output a map from items to counts.
-- Example: 
-- 
-- > count ['a', 'b', 'a'] = Map.fromList [('a',2), ('b',1)]
count :: (Ord a, Num int) => [(int,a)] -> Map a int
count list =
  foldl' (\mp (i,x) -> Map.insertWith' (+) x i mp) Map.empty list 

-- | Count the number of gates of each type in a circuit, with annotations,
-- treating subroutine calls as atomic gates.
anngatecount_of_circuit :: Circuit -> AnnGatecount
anngatecount_of_circuit (_,gs,_,_) = count $ map (\x -> (repeated x, gatetype x)) $ filter (not . is_comment) gs
  where
    is_comment (Comment _ _ _) = True
    is_comment _ = False
    repeated (Subroutine _ _ _ _ _ _ _ _ _ (RepeatFlag repeat)) = repeat
    repeated _ = 1

-- | Count the number of gates of each type in a circuit,
-- treating subroutine calls as atomic gates.
gatecount_of_circuit :: Circuit -> Gatecount
gatecount_of_circuit = unannotate_gatecount . anngatecount_of_circuit

-- | Given an 'AnnGatetype' describing a subroutine call
-- (possibly repeated),
-- and a gate count for the subroutine itself, return the gatecount 
-- of the subroutine call.
--
-- (This may be the reverse of the original subroutine, may have
-- controls added, etc.)
gatecount_of_subroutine_call :: ErrMsg -> AnnGatetype -> RepeatFlag -> AnnGatecount -> AnnGatecount
gatecount_of_subroutine_call e (AnnGatetypeSubroutine boxid inv cs ncf ctrble) (RepeatFlag reps) =
  (if inv then reverse_gatecount err_inv else id)
  . (if cs == nocontrols then id
       else case ctrble of
             AllCtl           -> add_controls_gatecount err_ctrl cs
             OnlyClassicalCtl -> add_controls_gatecount err_ctrl cs
             NoCtl            -> error $ err_ctrble)
  . (if reps == 1 then id else (Map.map (* reps)))
  . (if ncf then set_ncf_gatecount else id) 
  where
    err_inv = e . (("gatecount_of_subroutine_call, inverting subroutine " ++ longname ++ ": ") ++)
    err_ctrl = e . (("gatecount_of_subroutine_call, controlling subroutine " ++ longname ++ ": ") ++)
    err_ctrble = e $ "gatecount_of_subroutine_call: subroutine " ++ longname ++ " not controllable"
    longname = string_of_boxid boxid
    
gatecount_of_subroutine_call e _ _ = error $ e "internal error (gatecount_of_subroutine_call called on non-subroutine)"

-- | Given a circuit and gatecounts for its subroutines, 
-- give an (aggregated) gatecount for the circuit.
anngatecount_of_circuit_with_sub_cts :: ErrMsg -> Map BoxId AnnGatecount -> Circuit -> AnnGatecount
anngatecount_of_circuit_with_sub_cts e sub_cts (_,gs,_,_) =
  foldr action Map.empty gs
  where
    action (Comment _ _ _) = id
    action g@(Subroutine n _ _ _ _ _ _ _ _ reps) = 
      case Map.lookup n sub_cts of
        Nothing -> error $ e $ "subroutine not found: " ++ show n
        Just n_ct -> flip (Map.unionWith (+)) $
                       gatecount_of_subroutine_call e (gatetype g) reps n_ct
    action g = Map.insertWith' (+) (gatetype g) 1

-- | Give the aggregate gate count of a 'BCircuit'; that is, the
-- the total count of basic gates once all subroutines are fully inlined.
aggregate_gatecounts_of_bcircuit :: BCircuit -> Gatecount
aggregate_gatecounts_of_bcircuit (main_circ, namespace)
  = unannotate_gatecount $
    anngatecount_of_circuit_with_sub_cts e sub_cts main_circ
    where
      sub_cts = Map.map (anngatecount_of_circuit_with_sub_cts e sub_cts . circuit_of_typedsubroutine) namespace
      e = ("aggregate_gatecounts_of_bcircuit: " ++)

-- ** Wire usage count

-- | Count by how much a low-level gate changes the number of wires in the arity.

-- Implementation note: writing this function explicitly case-by-case appears
-- very slightly faster (~0.5%), but more fragile/less maintainable.
gate_wires_change :: Gate -> Integer
gate_wires_change g = 
  let (a_in,a_out) = gate_arity g
  in fromIntegral $ length a_out - length a_in

-- | Find the maximum number of wires used simultaneously in a 'BCircuit',
-- assuming all subroutines inlined. 
aggregate_maxwires_of_bcircuit :: BCircuit -> Integer
aggregate_maxwires_of_bcircuit (main_circ, namespace)
  = maxwires_of_circuit_with_sub_maxwires e sub_maxs main_circ
    where
      e = ("aggregate_maxwires_of_bcircuit: " ++)
      sub_maxs = Map.map (maxwires_of_circuit_with_sub_maxwires e sub_maxs . circuit_of_typedsubroutine) namespace

-- | Given a circuit and gatecounts for its subroutines, 
-- give an (aggregated) gatecount for the circuit.
maxwires_of_circuit_with_sub_maxwires :: ErrMsg -> Map BoxId Integer -> Circuit -> Integer
maxwires_of_circuit_with_sub_maxwires e sub_maxs (a1,gs,a2,_) =
  snd $ foldl (flip action) (in_wires, in_wires) gs
  where
    in_wires = fromIntegral $ IntMap.size a1
    update w_change (!w_old, !wmax_old) =
-- Implementation note: strictness in this pattern is to avoid putting the whole
-- tower of “max” applications on the stack.
      let w_new = w_old + w_change in (w_new, max wmax_old w_new)
    action g@(Subroutine n _ ws1 _ ws2 _ _ _ _ (RepeatFlag r)) = 
      case Map.lookup n sub_maxs of
        Nothing -> error $ "subroutine not found: " ++ show n
        Just n_max -> (update $ (fromIntegral $ length ws2) - n_max)
                      . (update $ n_max - (fromIntegral $ length ws1))
    action g = update $ gate_wires_change g

-- ** Printing gate counts

-- | Print a gate count, as a table of integers and gate types. 
print_gatecount :: Gatecount -> IO ()
print_gatecount cts = mapM_
  (\(gt,k) -> putStr (printf ("%" ++ show max_digits ++ "d: %s\n") k (string_of_gatetype gt)))
  (Map.assocs cts)
  where
    max_digits = maximum $ 5:(map ((1+) . floor . logBase 10 . fromIntegral) (Map.elems cts))

-- | Print the simple gate count, plus summary information, for a simple circuit.
print_gatecounts_circuit :: Circuit -> IO ()
print_gatecounts_circuit circ@(a1,gs,a2,n) = do
  print_gatecount cts
  putStrLn $ printf "Total gates: %d" $ sum $ Map.elems cts
  putStrLn $ printf "Inputs: %d" $ IntMap.size a1
  putStrLn $ printf "Outputs: %d" $ IntMap.size a2
  putStrLn $ printf "Qubits in circuit: %d" n
  where
    cts = gatecount_of_circuit circ

-- | Print gate counts for a boxed circuit:
-- first the simple gate count for each subroutine separately,
-- then the aggregated count for the whole circuit.
print_gatecounts_bcircuit :: BCircuit -> IO ()
print_gatecounts_bcircuit bcirc@(circ@(a1,_,a2,_),namespace) = do
  print_gatecounts_circuit circ
  when (not $ Map.null namespace) $ do
    sequence_ [ (putStrLn "") >> (print_gatecounts_subroutine sub) | sub <- Map.toList namespace ]
    putStrLn ""
    putStrLn "Aggregated gate count:" 
    let aggregate_cts = aggregate_gatecounts_of_bcircuit bcirc
        maxwires = aggregate_maxwires_of_bcircuit bcirc
    print_gatecount aggregate_cts
    putStrLn $ printf "Total gates: %d" $ sum $ Map.elems aggregate_cts
    putStrLn $ printf "Inputs: %d" $ IntMap.size a1
    putStrLn $ printf "Outputs: %d" $ IntMap.size a2
    putStrLn $ printf "Qubits in circuit: %d" maxwires

-- | Print gate counts for a named subroutine.
print_gatecounts_subroutine :: (BoxId, TypedSubroutine) -> IO ()
print_gatecounts_subroutine (boxid, TypedSubroutine ocirc _ _ _) = do
  putStrLn ("Subroutine: " ++ show name)
  putStrLn ("Shape: " ++ show shape)
  print_gatecounts_circuit circ
  where
    OCircuit (_, circ, _) = ocirc
    BoxId name shape = boxid

-- | Print gate counts for a static 'DBCircuit'. The circuit may not
-- use any dynamic lifting, or else an error will be produced.
print_gatecounts_dbcircuit :: ErrMsg -> DBCircuit a -> IO ()
print_gatecounts_dbcircuit e dbcirc = print_gatecounts_bcircuit bcirc where
  (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc
  errmsg x = e ("operation not permitted during gate count: " ++ x)

-- ----------------------------------------------------------------------
-- * Printing to multiple formats

-- | Available output formats.

data Format = 
  EPS         -- ^ Encapsulated PostScript graphics.
  | PDF       -- ^ Portable Document Format. One circuit per page.
  | PS        -- ^ PostScript. One circuit per page.
  | ASCII     -- ^ A textual representation of circuits.
  | Preview   -- ^ Don't print anything, but preview directly on screen (requires the external program /acroread/).
  | GateCount -- ^ Print statistics on gate counts.
  | CustomStyle FormatStyle
  deriving Show
    
-- | A mapping from lower-case strings (to be used, e.g., with command
-- line options) to available formats.
format_enum :: [(String, Format)]
format_enum = [
  ("eps", EPS),
  ("pdf", PDF),
  ("ps", PS),
  ("postscript", PS),
  ("ascii", ASCII),
  ("preview", Preview),
  ("gatecount", GateCount)
  ]
                    
-- | Print a low-level quantum circuit directly to the IO monad, using
-- the specified format.
print_dbcircuit :: Format -> ErrMsg -> DBCircuit a -> IO ()
print_dbcircuit EPS = print_dbcircuit_format eps
print_dbcircuit PDF = print_dbcircuit_format pdf
print_dbcircuit PS = print_dbcircuit_format ps
print_dbcircuit ASCII = print_dbcircuit_ascii
print_dbcircuit Preview = preview_dbcircuit
print_dbcircuit GateCount = print_gatecounts_dbcircuit
print_dbcircuit (CustomStyle fs) = print_dbcircuit_format fs

-- | Print a document to the requested format, which must be one of
-- 'PS', 'PDF', 'EPS', or 'Preview'.
print_of_document :: Format -> Document a -> IO a
print_of_document = print_of_document_custom custom

-- | Like 'print_of_document', but also takes a 'Custom' data
-- structure.
print_of_document_custom :: Custom -> Format -> Document a -> IO a
print_of_document_custom custom PS doc = render_custom_stdout Format_PS custom doc
print_of_document_custom custom PDF doc = render_custom_stdout Format_PDF custom doc
print_of_document_custom custom EPS doc = render_custom_stdout (Format_EPS 1) custom doc
print_of_document_custom custom Preview doc = preview_document_custom custom doc
print_of_document_custom custom format doc = error ("print_of_document: method " ++ show format ++ " can't be used in this context")

-- ======================================================================
-- * Generic printing

-- | Like 'print_unary', but also takes a stub error message.
print_errmsg :: (QCData qa) => ErrMsg -> Format -> (qa -> Circ b) -> qa -> IO ()
print_errmsg e format f shape = print_dbcircuit format e dbcircuit
  where 
    (in_bind, dbcircuit) = encapsulate_dynamic f shape

-- | Print a circuit generating function to the specified format; this
-- requires a shape parameter.
print_unary :: (QCData qa) => Format -> (qa -> Circ b) -> qa -> IO ()
print_unary = print_errmsg errmsg
  where 
    errmsg x = "print_unary: " ++ x

-- | Print a circuit generating function to the specified
-- format. Unlike 'print_unary', this can be applied to a
-- circuit-generating function in curried form with /n/ arguments, for
-- any /n >= 0/. It then requires /n/ shape parameters.
-- 
-- The type of this heavily overloaded function is difficult to
-- read. In more readable form, it has all of the following types:
-- 
-- > print_generic :: Format -> Circ qa -> IO ()
-- > print_generic :: (QCData qa) => Format -> (qa -> Circ qb) -> a -> IO ()
-- > print_generic :: (QCData qa, QCData qb) => Format -> (qa -> qb -> Circ qc) -> a -> b -> IO ()
-- 
-- and so forth.
 
print_generic :: (QCData qa, QCurry qfun qa b, Curry fun qa (IO())) => Format -> qfun -> fun
print_generic format f = g where
  f1 = quncurry f
  g1 = print_errmsg errmsg format f1
  g = mcurry g1
  errmsg x = "print_generic: " ++ x

-- | Like 'print_generic', but only works at simple types, and
-- therefore requires no shape parameters.
print_simple :: (QCData qa, QCurry qfun qa b, Curry fun qa (IO()), QCData_Simple qa) => Format -> qfun -> IO ()
print_simple format f = print_errmsg errmsg format f1 fs_shape where
  f1 = quncurry f
  errmsg x = "print_simple: " ++ x