------------------------------------------------------------------------------
--                                                                          --
--                 Copyright (C) 2015-2016, AdaCore                         --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
--                                                                          --
--  This file is based on:                                                  --
--                                                                          --
--   @file    stm32f429i_discovery_lcd.c                                    --
--   @author  MCD Application Team                                          --
--   @version V1.1.0                                                        --
--   @date    19-June-2014                                                  --
--   @brief   This file includes the LTDC driver to control LCD display.    --
--                                                                          --
--   COPYRIGHT(c) 2014 STMicroelectronics                                   --
------------------------------------------------------------------------------

with Ada.Interrupts.Names;
with Ada.Unchecked_Conversion;

with System;         use System;

with STM32_SVD.LTDC; use STM32_SVD.LTDC;
with STM32_SVD.RCC;  use STM32_SVD.RCC;
with HAL.Bitmap;

package body STM32.LTDC is

   pragma Warnings (Off, "* is not referenced");
   type LCD_Polarity is
     (Polarity_Active_Low,
      Polarity_Active_High) with Size => 1;
   type LCD_PC_Polarity is
     (Input_Pixel_Clock,
      Inverted_Input_Pixel_Clock) with Size => 1;
   pragma Warnings (On, "* is not referenced");

   function To_Bool is new Ada.Unchecked_Conversion (LCD_Polarity, Boolean);
   function To_Bool is new Ada.Unchecked_Conversion (LCD_PC_Polarity, Boolean);

   --  Extracted from STM32F429x.LTDC
   type Layer_Type is record
      LCR        : L1CR_Register;
      --  Layerx Control Register

      LWHPCR     : L1WHPCR_Register;
      --  Layerx Window Horizontal Position Configuration Register

      LWVPCR     : L1WVPCR_Register;
      --  Layerx Window Vertical Position Configuration Register

      LCKCR      : L1CKCR_Register;
      --  Layerx Color Keying Configuration Register

      LPFCR      : L1PFCR_Register;
      --  Layerx Pixel Format Configuration Register

      LCACR      : L1CACR_Register;
      --  Layerx Constant Alpha Configuration Register

      LDCCR      : L1DCCR_Register;
      --  Layerx Default Color Configuration Register

      LBFCR      : L1BFCR_Register;
      --  Layerx Blending Factors Configuration Register

      Reserved_0 : UInt32;
      Reserved_1 : UInt32;

      LCFBAR     : UInt32;
      --  Layerx Color Frame Buffer Address Register

      LCFBLR     : L1CFBLR_Register;
      --  Layerx Color Frame Buffer Length Register

      LCFBLNR    : L1CFBLNR_Register;
      --  Layerx ColorFrame Buffer Line Number Register

      Reserved_2 : UInt32;
      Reserved_3 : UInt32;
      Reserved_4 : UInt32;

      LCLUTWR    : L1CLUTWR_Register;
      --  Layerx CLUT Write Register
   end record with Volatile;

   for Layer_Type use record
      LCR        at  0 range 0 .. 31;
      LWHPCR     at  4 range 0 .. 31;
      LWVPCR     at  8 range 0 .. 31;
      LCKCR      at 12 range 0 .. 31;
      LPFCR      at 16 range 0 .. 31;
      LCACR      at 20 range 0 .. 31;
      LDCCR      at 24 range 0 .. 31;
      LBFCR      at 28 range 0 .. 31;
      Reserved_0 at 32 range 0 .. 31;
      Reserved_1 at 36 range 0 .. 31;
      LCFBAR     at 40 range 0 .. 31;
      LCFBLR     at 44 range 0 .. 31;
      LCFBLNR    at 48 range 0 .. 31;
      Reserved_2 at 52 range 0 .. 31;
      Reserved_3 at 56 range 0 .. 31;
      Reserved_4 at 60 range 0 .. 31;
      LCLUTWR    at 64 range 0 .. 31;
   end record;
   type Layer_Access is access all Layer_Type;

   BF1_Constant_Alpha : constant := 2#100#;
   BF2_Constant_Alpha : constant := 2#101#;
   BF1_Pixel_Alpha    : constant := 2#110#;
   BF2_Pixel_Alpha    : constant := 2#111#;

   G_Layer1_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L1CR'Address;
   G_Layer2_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L2CR'Address;

   function Get_Layer (Layer : LCD_Layer) return Layer_Access;
   --  Retrieve the layer's registers

   protected Sync is
      --  Apply pending buffers on Vertical Sync. Caller must call Wait
      --  afterwards.
      procedure Apply_On_VSync;

      --  Wait for an interrupt.
      entry Wait;

      procedure Interrupt;
      pragma Attach_Handler
        (Interrupt, Ada.Interrupts.Names.LTDC_Interrupt);

   private
      Not_Pending : Boolean := True;
   end Sync;

   ----------
   -- Sync --
   ----------

   protected body Sync is

      ----------
      -- Wait --
      ----------

      entry Wait when Not_Pending is
      begin
         null;
      end Wait;

      --------------------
      -- Apply_On_VSync --
      --------------------

      procedure Apply_On_VSync is
      begin
         Not_Pending := False;
         --  Enable the Register Refresh interrupt
         LTDC_Periph.IER.RRIE := True;
         --  And tell the LTDC to apply the layer registers on refresh
         LTDC_Periph.SRCR.VBR := True;
      end Apply_On_VSync;

      ---------------
      -- Interrupt --
      ---------------

      procedure Interrupt
      is
      begin
         if LTDC_Periph.ISR.RRIF then
            LTDC_Periph.IER.RRIE := False;
            LTDC_Periph.ICR.CRRIF  := True;

            Not_Pending := True;
         end if;
      end Interrupt;
   end Sync;

   ---------------
   -- Get_Layer --
   ---------------

   function Get_Layer (Layer : LCD_Layer) return Layer_Access is
   begin
      if Layer = Layer1 then
         return G_Layer1_Reg'Access;
      else
         return G_Layer2_Reg'Access;
      end if;
   end Get_Layer;

   -------------------
   -- Reload_Config --
   -------------------

   procedure Reload_Config
     (Immediate : Boolean := False)
   is
   begin
      if Immediate then
         LTDC_Periph.SRCR.IMR := True;

         loop
            exit when not LTDC_Periph.SRCR.IMR;
         end loop;
      else
         Sync.Apply_On_VSync;
         Sync.Wait;
      end if;
   end Reload_Config;

   ------------------
   -- To_LTDC_Mode --
   ------------------

   function To_LTDC_Mode (HAL_Mode : HAL.Framebuffer.FB_Color_Mode)
                          return STM32.LTDC.Pixel_Format
   is
   begin
      case HAL_Mode is
         when HAL.Bitmap.ARGB_8888 => return STM32.LTDC.Pixel_Fmt_ARGB8888;
         when HAL.Bitmap.RGB_888   => return STM32.LTDC.Pixel_Fmt_RGB888;
         when HAL.Bitmap.RGB_565   => return STM32.LTDC.Pixel_Fmt_RGB565;
         when HAL.Bitmap.ARGB_1555 => return STM32.LTDC.Pixel_Fmt_ARGB1555;
         when HAL.Bitmap.ARGB_4444 => return STM32.LTDC.Pixel_Fmt_ARGB4444;
         when HAL.Bitmap.L_8       => return STM32.LTDC.Pixel_Fmt_L8;
         when HAL.Bitmap.AL_44     => return STM32.LTDC.Pixel_Fmt_AL44;
         when HAL.Bitmap.AL_88     => return STM32.LTDC.Pixel_Fmt_AL88;
         when others =>
            raise Program_Error;
      end case;
   end To_LTDC_Mode;

   ---------------------
   -- Set_Layer_State --
   ---------------------

   procedure Set_Layer_State
     (Layer   : LCD_Layer;
      Enabled : Boolean)
   is
      L   : constant Layer_Access := Get_Layer (Layer);
   begin
      if L.LCR.LEN /= Enabled then
         L.LCR.LEN := Enabled;
         Reload_Config (Immediate => True);
      end if;
   end Set_Layer_State;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize
     (Width         : Positive;
      Height        : Positive;
      H_Sync        : Natural;
      H_Back_Porch  : Natural;
      H_Front_Porch : Natural;
      V_Sync        : Natural;
      V_Back_Porch  : Natural;
      V_Front_Porch : Natural;
      PLLSAI_N      : UInt9;
      PLLSAI_R      : UInt3;
      DivR          : Natural)
   is
      DivR_Val : PLLSAI_DivR;
      Timing_H : UInt16;
      Timing_V : UInt16;

   begin
      if Initialized then
         return;
      end if;

      if DivR = 2 then
         DivR_Val := PLLSAI_DIV2;
      elsif DivR = 4 then
         DivR_Val := PLLSAI_DIV4;
      elsif DivR = 8 then
         DivR_Val := PLLSAI_DIV8;
      elsif DivR = 16 then
         DivR_Val := PLLSAI_DIV16;
      else
         raise Constraint_Error with "Invalid DivR value: 2, 4, 8, 16 allowed";
      end if;

      Disable_PLLSAI;

      RCC_Periph.APB2ENR.LTDCEN := True;
      RCC_Periph.APB2RSTR.LTDCRST := True;
      RCC_Periph.APB2RSTR.LTDCRST := False;

      --  Disable output + both layers
      LTDC_Periph.GCR.LTDCEN := False;
      LTDC_Periph.L1CR.LEN := False;
      LTDC_Periph.L2CR.LEN := False;

      LTDC_Periph.GCR.VSPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.HSPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.DEPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.PCPOL := To_Bool (Inverted_Input_Pixel_Clock);

      Set_PLLSAI_Factors
        (LCD  => PLLSAI_R,
         VCO  => PLLSAI_N,
         DivR => DivR_Val);
      Enable_PLLSAI;

      --  Synchronization size
      Timing_H := UInt16 (H_Sync - 1);
      Timing_V := UInt16 (V_Sync - 1);
      LTDC_Periph.SSCR :=
        (HSW    => SSCR_HSW_Field (Timing_H),
         VSH    => SSCR_VSH_Field (Timing_V),
         others => <>);

      --  Accumulated Back Porch
      Timing_H := Timing_H + UInt16 (H_Back_Porch);
      Timing_V := Timing_V + UInt16 (V_Back_Porch);
      LTDC_Periph.BPCR :=
        (AHBP   => BPCR_AHBP_Field (Timing_H),
         AVBP   => BPCR_AVBP_Field (Timing_V),
         others => <>);

      --  Accumulated Active Width/Height
      Timing_H := Timing_H + UInt16 (Width);
      Timing_V := Timing_V + UInt16 (Height);
      LTDC_Periph.AWCR :=
        (AAW    => AWCR_AAW_Field (Timing_H),
         AAH    => AWCR_AAH_Field (Timing_V),
         others => <>);

      --  VTotal Width/Height
      Timing_H := Timing_H + UInt16 (H_Front_Porch);
      Timing_V := Timing_V + UInt16 (V_Front_Porch);
      LTDC_Periph.TWCR :=
        (TOTALW => TWCR_TOTALW_Field (Timing_H),
         TOTALH => TWCR_TOTALH_Field (Timing_V),
         others => <>);

      --  Background color to black
      LTDC_Periph.BCCR.BC := 0;

      LTDC_Periph.GCR.LTDCEN := True;
   end Initialize;

   -----------
   -- Start --
   -----------

   procedure Start is
   begin
      LTDC_Periph.GCR.LTDCEN := True;
   end Start;

   ----------
   -- Stop --
   ----------

   procedure Stop is
   begin
      LTDC_Periph.GCR.LTDCEN := False;
   end Stop;

   -----------------
   -- Initialized --
   -----------------

   function Initialized return Boolean is
   begin
      return LTDC_Periph.GCR.LTDCEN;
   end Initialized;

   ----------------
   -- Layer_Init --
   ----------------

   procedure Layer_Init
     (Layer          : LCD_Layer;
      Config         : Pixel_Format;
      Buffer         : System.Address;
      X, Y           : Natural;
      W, H           : Positive;
      Constant_Alpha : UInt8 := 255;
      BF             : Blending_Factor := BF_Pixel_Alpha_X_Constant_Alpha)
   is
      L        : constant Layer_Access := Get_Layer (Layer);
   begin
      --  Horizontal start and stop = sync + Back Porch
      L.LWHPCR :=
        (WHSTPOS => L1WHPCR_WHSTPOS_Field (LTDC_Periph.BPCR.AHBP) + 1 +
             L1WHPCR_WHSTPOS_Field (X),
         WHSPPOS => L1WHPCR_WHSPPOS_Field (LTDC_Periph.BPCR.AHBP) +
             L1WHPCR_WHSPPOS_Field (X + W),
         others  => <>);

      --  Vertical start and stop
      L.LWVPCR :=
        (WVSTPOS => LTDC_Periph.BPCR.AVBP + 1 + UInt11 (Y),
         WVSPPOS => LTDC_Periph.BPCR.AVBP + UInt11 (Y + H),
         others  => <>);

      L.LPFCR.PF := Pixel_Format'Enum_Rep (Config);

      L.LCACR.CONSTA := Constant_Alpha;

      L.LDCCR := (others => 0);

      case BF is
         when BF_Constant_Alpha =>
            L.LBFCR.BF1 := BF1_Constant_Alpha;
            L.LBFCR.BF2 := BF2_Constant_Alpha;
         when BF_Pixel_Alpha_X_Constant_Alpha =>
            L.LBFCR.BF1 := BF1_Pixel_Alpha;
            L.LBFCR.BF2 := BF2_Pixel_Alpha;
      end case;

      L.LCFBLR :=
        (CFBLL  => UInt13 (W * Bytes_Per_Pixel (Config)) + 3,
         CFBP   => UInt13 (W * Bytes_Per_Pixel (Config)),
         others => <>);

      L.LCFBLNR.CFBLNBR := UInt11 (H);

      Set_Frame_Buffer (Layer, Buffer);

      L.LCR.LEN := True;
      Reload_Config (True);
   end Layer_Init;

   ----------------------
   -- Set_Frame_Buffer --
   ----------------------

   procedure Set_Frame_Buffer
     (Layer : LCD_Layer; Addr : Frame_Buffer_Access)
   is
      function To_Word is new Ada.Unchecked_Conversion
        (Frame_Buffer_Access, UInt32);
   begin
      if Layer = Layer1 then
         LTDC_Periph.L1CFBAR := To_Word (Addr);
      else
         LTDC_Periph.L2CFBAR := To_Word (Addr);
      end if;
   end Set_Frame_Buffer;

   ----------------------
   -- Get_Frame_Buffer --
   ----------------------

   function Get_Frame_Buffer
     (Layer : LCD_Layer)
      return Frame_Buffer_Access
   is
      L : constant Layer_Access := Get_Layer (Layer);
      function To_FBA is new Ada.Unchecked_Conversion
        (UInt32, Frame_Buffer_Access);
   begin
      return To_FBA (L.LCFBAR);
   end Get_Frame_Buffer;

   --------------------
   -- Set_Background --
   --------------------

   procedure Set_Background (R, G, B : UInt8) is
      RShift : constant UInt32 := Shift_Left (UInt32 (R), 16);
      GShift : constant UInt32 := Shift_Left (UInt32 (G), 8);
   begin
      LTDC_Periph.BCCR.BC :=
        UInt24 (RShift) or UInt24 (GShift) or UInt24 (B);
   end Set_Background;

end STM32.LTDC;
